Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / SCREEN.PRG < prev next >

Wrap

Text File | 1993-12-14 | 141.3 KB | 3,491 lines

*----------------------------------------------------------------------- *-- Program...: SCREEN.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 08/02/1993 *-- Notes.....: A few routines not left in PROC.PRG, these are not used *- as much by my own systems. See the file: README.TXT for *-- details on how to use this library file. *----------------------------------------------------------------------- FUNCTION Radio *----------------------------------------------------------------------- *-- Programmer..: Ed Lafferty (CIS: 76150,3302) *-- Date........: 06/08/1992 *-- Notes.......: Routine to create and size a popup with radio buttons *-- for choosing only one of up to four options. Pressing *-- the <Space Bar> on an option turns it on or off. *-- Pressing <Enter> chooses the selected option and *-- leaves the routine. *-- Written for.: dBase IV, 1.1 *-- Rev. History: 02/25/1992 - original procedure. *-- 02/27/1992 -- Ken Mayer -- added option for color, but *-- had to take number of choices back to 4 to do so. *-- Minor alterations performed to add color choice ... *-- and cleaning up after self ... (original cleared the *-- screen first ... this version saves screen, restores *-- back to it ...) Oh yeah, I turned it into a function, *-- rather than a procedure, as well. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: Radio(<nULRow>,<nULCol>,<nChoice>,"<cTxt1>",; *-- "<cTxt2>","<cTxt3>","<cTxt4>","<cTitle>",; *-- "<cColor>") *-- Example.....: cPort = Radio(8,15,1,"LPT1","LPT2","LPT3","",; *-- "Choose a printer port","rg+/gb,n/w,rg+/gb") *-- Returns.....: number of chosen button in nChoice *-- Parameters..: nUlrow = upper left row of popup *-- nUlcol = upper left column of popup *-- nChoice = default chosen button *-- cTxt1 = Text for 1st button *-- cTxt2 = " " 2nd " *-- cTxt3 = " " 3rd " *-- cTxt4 = " " 4th " *-- cTitle = Text for the box title *-- cColor = Color string (i.e., "RG+/GB,N/W,RG+/GB") *----------------------------------------------------------------------- parameters nUlrow, nUlcol, nChoice, cTxt1, cTxt2, cTxt3, cTxt4,; cTitle, cColor private nHeight, nKey, nCnt, nWidth, cStr, cTxt0, cMidCol, ; cFirstCol,cCursor m->cCursor = set("CURSOR") store m->cTitle to m->cTxt0 save screen to sRadio store 0 to m->nHeight, m->nKey, m->nCnt, m->nWidth store m->nChoice to m->nOrig && in case user presses <Esc> to exit ... *-- deal with these colors in displaying some stuff ... m->cMidCol = colorbrk(m->cColor,2) *-- First color (for message) is easier ... m->cFirstCol = colorbrk(m->cColor,1) *-- Determine height and width of popup do case case len(m->cTxt4) > 0 m->nHeight = 4 case len(m->cTxt3) > 0 m->nHeight = 3 case len(m->cTxt2) > 0 m->nHeight = 2 otherwise m->nHeight = 1 endcase do while m->nCnt <=m->nHeight store "cTxt"+str(m->nCnt,1) to m->cStr if len(&cStr.) > m->nWidth m->nWidth = len(&cStr.) endif m->nCnt = m->nCnt + 1 enddo *-- create popup define window wRadio from m->nULRow,m->nULCol to ; m->nULRow+m->nHeight+3,m->nULCol+m->nWidth+9; double color &cColor. do center with 23,80,m->cFirstCol,"Press "+chr(24)+chr(25)+; " <Space> to select/de-select, <Enter> to quit" activate screen do shadow with m->nULRow, m->nULCol, m->nULRow+m->nHeight+3, ; m->nULCol+m->nWidth+9 activate window wRadio *-- display screen store 1 to m->nCnt do center with 0, m->nWidth+8, "", m->cTitle do while m->nCnt <= m->nHeight store "cTxt"+str(m->nCnt,1) to m->cStr @ m->nCnt+1, 2 SAY "[ ]" color &cMidCol. @ m->nCnt+1, 6 say &cStr. m->nCnt = m->nCnt + 1 enddo *-- prepare for and get nChoice if m->nChoice > 0 store m->nChoice to m->nCnt @m->nCnt+1,3 say "˛" color &cMidCol. else store 1 to m->nCnt endif store .F. to m->lDone *-- this loop processes user input ... do while .not. m->lDone @ m->nCnt+1,3 say "" color &cMidCol. m->nKey = inkey(0) do case case m->nKey = 27 && Press Esc to exit store m->nOrig to m->nChoice && Leave at "default" store .T. to m->lDone case m->nKey = 13 store .T. to m->lDone case m->nKey = 32 && Press Enter or Space set cursor off if m->nChoice = m->nCnt @ m->nCnt+1,3 say " " color &cMidCol. store 0 to m->nChoice else @ m->nChoice+1,3 say " " color &cMidCol. @ m->nCnt+1,3 say "˛" color &cMidCol. store m->nCnt to m->nChoice endif set cursor on case m->nKey = 5 && Press up arrow if m->nCnt > 1 m->nCnt = m->nCnt - 1 else m->nCnt = m->nHeight endif case m->nKey = 24 && Press down arrow if m->nCnt < m->nHeight m->nCnt = m->nCnt + 1 else m->nCnt = 1 endif endcase enddo *-- cleanup release window wRadio restore screen from sRadio release screen sRadio set message to set cursor &cCursor. RETURN m->nChoice *-- EoF: Radio() PROCEDURE CheckBox *----------------------------------------------------------------------- *-- Programmer..: Ed Lafferty (CIS: 76150,3302) *-- Date........: 04/22/1993 *-- Notes.......: Routine to create and size a popup with check boxes *-- for choosing any of a number (up to five) options. *-- Pressing the <Space Bar> on an option turns it on or *-- off. Pressing <Enter> chooses the selected option and *-- leaves the routine. You must use a data structure with *-- logical fields, or memvars that are logical for this. *-- Either way, even if you don't use five logical fields/ *-- memvars, you must pass a field/memvar to the procedure *-- -- see Example below (the logicals -- lCHK1, lCHK2, *-- etc.-- must be fields or memvars due to a limitation in *-- parameter passing in dBASE IV.) *-- Written for.: dBase IV, Version 1.5+ *-- Rev. History: 02/25/1992 -- Original procedure. *-- 02/28/1992 -- Ken Mayer -- modified to allow passing *-- cColor, and a little cleanup of code and such. Minor *-- changes. *-- 04/22/1993 -- Angus Scott-Fleming: *-- Revised for 1.5: *-- Turned cursor on *-- Moved help-line info inside box. *-- Reorganized parameters to allow calling *-- with variable # of choices, and evaluate with *-- pCOUNT(). NOTE: If more than 9 pairs are *-- needed, two loops will have to be changed from *-- STR(NCNT,1) to lTrim STR(cCnt,2)) *-- Enabled error-trapping for poorly located boxes. *-- Appended "." to all &Macros. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: do checkbox with <nULCol>,<nULRow>,<cTitle>,<cColor>,; *-- <lchk1>,<cTxt1>,[<lchk2>,<cTxt2>]; *-- [,<lchk3>,<cTxt3>][,<lchk4>,<cTxt4>]; *-- [... to 9] *-- Example.....: do Checkbox with 8, 15, "Choose a printer port",; *-- "rg+/gb,w+/n,rg+/gb", lchk1, "LPT1", lchk2, ; *-- "LPT2", lchk3, "LPT3" *-- Returns.....: .T. for selected items, .F. for non-selected items -- *-- this routine changes the value of the logical fields *-- passed to it. *-- Parameters..: nULRow = upper left row of popup *-- nULCol = upper left column of popup *-- cTitle = Title for box *-- cColor = Colors for window *-- lChkn = default value of box 'n' -- MUST BE *-- FIELDS/MEMVARS *-- cTxtn = Text for 'n'th box *-- cColor = Colors to be used in window ... *----------------------------------------------------------------------- parameters nUlrow, nUlcol, cTitle, cColor, lChk1, cTxt1, lChk2, ; cTxt2, lChk3, cTxt3, lChk4, cTxt4, lChk5, cTxt5, lChk6,; cTxt6, lChk7, cTxt7, lChk8, cTxt8, lChk9, cTxt9 private nHeight, nKey, nCnt, nWidth, cMidCol, cFirstCol, cCursor,; cPrompt, nBRRow, nBRCol *-- setup ... m->cCursor = set("CURSOR") save screen to sCheck store 0 to m->nHeight, m->nKey, m->nWidth m->cPrompt = "Press "+chr(24)+chr(25)+; ", <Space> to select/de-select, <Enter> to quit" *-- save original settings, in case <Esc> gets pressed below ... *-- determine height/width of popup m->nWidth = max(len(m->cPrompt),len(m->cTitle)) m->nHeight = (pcount() - 4)/2 m->nCnt = 0 do while m->nCnt < m->nHeight m->nCnt = m->nCnt + 1 m->cCnt = str(m->nCnt,1) private lOrig&cCnt. store lChk&cCnt. to lOrig&cCnt. m->nWidth = max(m->nWidth,len(cTxt&cCnt.)) enddo *-- add border to window m->nWidth = min(m->nWidth+8,79) *-- deal with some colors ... m->cMidCol = colorbrk(m->cColor,2) m->cFirstCol = colorbrk(m->cColor,1) *-- create popup and trap errors defining the window m->nBRRow = m->nULRow + m->nHeight + 5 m->nBRCol = m->nULCol + m->nWidth if m->nBRRow > 24 *-- center window vertically m->nULRow = max(12-(m->nHeight+5)/2,0) m->nBRRow = min(23,(m->nULRow+m->nHeight+5)) endif if m->nBRCol > 80 *-- center window horizontally m->nULCol = max(40 - m->nWidth/2,0) m->nBRCol = min(79,(m->nULCol+m->nWidth)) endif define window wCheck from m->nULRow, m->nULCol to m->nBRRow, ; m->nBRCol double color &cColor. activate screen do shadow with m->nULRow,m->nULCol,m->nBRRow,m->nBRCol activate window wCheck *-- paint screen do center with 0,m->nWidth,"",m->cTitle store 1 to m->nCnt do while m->nCnt <= m->nHeight store "cTxt"+str(m->nCnt,1) to m->cStr store "lChk"+str(m->nCnt,1) to m->cChk @m->nCnt+1,2 say "["+iif(&cChk.,"X"," ")+"]" color &cMidCol. @m->nCnt+1,6 say left(&cStr.,m->nWidth-9) m->nCnt = m->nCnt + 1 enddo do center with m->nCnt+2,m->nWidth,"",m->cPrompt *-- prepare for and get nChoice store 1 to m->nCnt store .F. to m->lDone do while .not. m->lDone store "lChk"+str(m->nCnt,1) to m->cChk @ m->nCnt+1,3 say "" color &cMidCol. nkey = inkey(0) do case case m->nKey = 27 && Press Esc to exit m->nCnt = 0 do while m->nCnt < m->nHeight m->nCnt = m->nCnt + 1 m->cCnt = str(m->nCnt,1) store lOrig&cCnt. to lChk&cCnt. enddo store .T. to m->lDone case m->nKey = 13 && Press Enter when finished store .T. to m->lDone case m->nKey = 32 && Press Space set cursor off if &cChk. && Box was already selected, @ m->nCnt+1,3 say " " color &cMidCol. && so now de-select it store .F. to &cChk. else && Box was not already selected, @ m->nCnt+1,3 say "X" color &cMidCol. && so now select it store .T. to &cChk. endif set cursor on case m->nKey = 5 && Press up arrow if m->nCnt > 1 m->nCnt = m->nCnt - 1 else m->nCnt = m->nHeight endif case m->nKey = 24 && Press down arrow if m->nCnt < m->nHeight m->nCnt = m->nCnt + 1 else m->nCnt = 1 endif endcase enddo *-- Cleanup release window wCheck restore screen from sCheck release screen sCheck set message to set cursor &cCursor. RETURN *-- EoP: ChkBox FUNCTION MenuPad *----------------------------------------------------------------------- *-- Programmer..: Douglas P. Saine (CIS: 74660,3574) *-- Date........: 02/11/1992 *-- Notes.......: Used to create menu prompts of an even length. It *-- works on any prompt - menu pads or popups. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 02/07/1992 - original function. *-- 02/11/1992 -- Ken Mayer -- modified to truncate *-- <cChoice> if it's longer than <nLength>. *-- Calls.......: ALLTRIM() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: MenuPad("<cChoice>",<nLength>) *-- Example.....: Define pad pPad1 of mMain; *-- prompt MenuPad("Menu Choice1",25) at 2,5 *-- Returns.....: <cChoice> padded with spaces (or truncated, if *-- necessary) to <nLength>. *-- Parameters..: cChoice = Menu-Pad/Popup-Bar Prompt description *-- nLength = Length of pad/bar ... *----------------------------------------------------------------------- parameters cChoice, nLength private cReturn if len(alltrim(m->cChoice)) > m->nLength && is it too long? m->cReturn = left(m->cChoice,m->nLength) && truncate it ... else && otherwise, pad it with spaces to the length required m->cReturn = m->cChoice + space(m->nLength-; len(alltrim(m->cChoice))) endif RETURN m->cReturn *-- EoF: MenuPad() FUNCTION Banner *----------------------------------------------------------------------- *-- Programmer..: Dan Madoni (Borland) *-- Date........: 09/01/1991 *-- Notes.......: This will display a left-scrolling message on the *-- screen within the boundaries specified in the UDF by *-- the user. It will wait for a keypress and then go *-- away. Taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 09/01/1991 -- Original *-- Usage.......: Banner(<nRow>,<nCol>,<nWidth>,"<cMessage>","<cColor>") *-- Example.....: ?? Banner(5,30,20,"Love your tie, is it new?","w+/r") *-- Returns.....: Null ("") *-- Parameters..: nRow = Leftmost ROW position of scrolled message *-- nCol = Leftmost COL position of scrolled message *-- nWidth = Length of displayable area starting at *-- nRow,nCol *-- cMessage = Message to be scrolled *-- cColor = Color of scrolling message *----------------------------------------------------------------------- parameters nRow,nCol,nWidth,cMessage,cColor private cCursor,cTalk,cMsg,nCounter,cPause *-- save some environment essentials save screen to sBanner m->cCursor = set("CURSOR") m->cTalk = set("TALK") set cursor off set talk off *-- deal with message m->cMsg = space(m->nWidth)+m->cMessage+" " m->nCounter = 0 *-- loop do while .t. m->nCounter = m->nCounter + 1 if m->nCounter > len(m->cMsg) m->nCounter = 1 endif *-- user hits any key m->nPause = inkey(.15) if m->nPause # 0 exit endif *-- display message within scrollable area @m->nRow,m->nCol say substr(m->cMsg,m->nCounter,m->nWidth) ; color &cColor. enddo *-- restore environment restore screen from sBanner release screen sBanner set cursor &cCursor. set talk &cTalk. RETURN "" *-- EoF: Banner() FUNCTION SeeMatch *----------------------------------------------------------------------- *-- Programmer..: Dan Madoni (Borland) *-- Date........: 06/12/1992 *-- Notes.......: Can be included in format screen to display an instant *-- lookup match on a particular field. A shadowed box *-- will appear with the matching value ... Taken from *-- TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 09/01/1991 -- Original *-- 06/12/1992 -- Minor -- added call to RECOLOR *-- Calls.......: RECOLOR Procedure in PROC.PRG *-- Called by...: None *-- Usage.......: SeeMatch("<cFile>",<cSeekExp>,"<cReturn>",<nULRow>,; *-- <nULCol>,<nBRRow>,<nBRCol>,"<cColor>) *-- Example.....: SeeMatch("TRAVEL",LASTNAME,"TRAVELCODE",2,40,4,60,; *-- "w+/r") *-- Returns.....: .t. *-- Parameters..: cFile = Database alias in which lookup will be *-- performed. This file must already be USEd *-- in some area. *-- cSeekExp = Expression which will be SEEKed. *-- cReturn = Name of field to contain the 'return' *-- value. *-- nULRow = Upper Left Row for box *-- nULCol = Upper Left Column for box *-- nBRRow = Bottom Right Row *-- nBRCol = Bottom Right Column *-- cColor = Color of box *---------------------------------------------------------------------- parameters cFile,cSeeExp,cReturn,nULRow,nULCol,nBRRow,nBRCol,cColor private cRetVal, cAttr, cStartFile *-- store starting position ... m->cStartFile = alias() select &cFile. *-- look for a matching expression seek m->cSeekExp if found() m->cRetVal = &cReturn. else m->cRetVal = "<Not Found>" endif *-- Store current color and draw a box m->cAttr = set("ATTRIBUTES") @m->nULRow+1,m->nULCol+1 fill to m->nBRRow+1,m->nBRCol+1; color w/n && shadow set color to &cColor. @m->nULRow,m->nULCol clear to m->nBRRow,m->nBRCol && clear out area && text will go in @m->nULRow,m->nULCol To m->nBRRow,m->nBRCol && draw box *-- display matching expresion, and return to initial area ... @m->nULRow+1,m->nULCol+2 say m->cRetVal do ReColor with m->cAttr select m->cStartFile RETURN .t. *-- EoF: SeeMatch() FUNCTION Dialog *----------------------------------------------------------------------- *-- Programmer..: Larry Quaglia (Borland) *-- Date........: 06/09/1992 *-- Notes.......: This routine provides a 'standard' set of dialogue *-- boxes and buttons for all applications. The concept is *-- to provide standardization for your apps. Taken from *-- TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 11/01/1991 -- first published in TechNotes. *-- 06/09/1992 -- Modified to handle explicit colors, *-- changed the color parameters a tad ... *-- (Ken Mayer) *-- Calls.......: SHADOW Function in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Dialog("<cMsg>",<nType>,"<cBorder>",<nDefBut>,; *-- <lShadow>,"<cWind>","<cButton>") *-- Example.....: Dialog("We have completed the transaction.",0,; *-- "DOUBLE",0,.t.,"RG+/GB","W+/N") *-- Returns.....: Character -- Either 'ERROR' or title of Button. *-- Parameters..: cMsg = Message to be displayed -- maximum of 78 *-- characters (one line only) *-- nType = Dialogue box TYPE. Options are 0 to 5: *-- 0: 'OK' *-- 1: 'OK' 'CANCEL' *-- 2: 'ABORT' 'RETRY' 'IGNORE' *-- 3: 'YES' 'NO' 'CANCEL' *-- 4: 'YES' 'NO' *-- 5: 'RETRY' 'CANCEL' *-- cBorder = Border Style -- options are: "" (null) for *-- SINGLE, DOUBLE or PANEL. *-- nDefBut = Default Button. *-- lShadow = Display with a shadow or not (both on window *-- and buttons)? *-- cWind = Window Colors (must be valid dBASE color *-- combo i.e., "RG+/GB") *-- cButton = Highlighted Button Color (Same as above, *-- should contrast ...) *----------------------------------------------------------------------- parameters cMsg,nType,cBorder,nDefBut,lShadow,cWind,cButton private nMsgLen,cNewColor,aButton,nMaxLine,nY,nBoxLen,nNumButton,; nCounter,nBasex,nYCol,nMsgLoc,cCurColor save screen to sDialog && so we can restore at end of routine *-- determine length of message m->nMsgLen = len(trim(ltrim(m->cMsg))) + 1 *-- Check for valid parms do case case m->nMsgLen > 78 RETURN "ERROR - Message Length" case .not. (upper(m->cBorder) = "DOUBLE" .or. ; upper(m->cBorder) = "PANEL" .or.; len(trim(m->cBorder)) = 0) RETURN "ERROR - Border" endcase *-- save current color info and set color to user-defined m->cCurColor = set("ATTRIBUTES") set color of normal to &cWind. set color of box to &cWind. set color of message to &cWind. set color of highlight to &cButton. *-- Allow use of <Tab> to move from button to button on key label tab keyboard chr(4) && act as if right arrow && were pushed *-- Define button array -- max of 3 buttons (at the moment) declare aButton[3] aButton[1] = "" aButton[2] = "" aButton[3] = "" *-- Establish screen height to properly center dialogue box m->nMaxLine = iif(right(set("DISP"),2) = "43",43,24) *-- Determine length of passed "message" parameter. If long enough, *-- make the dialog box a little bigger. If very short, make it just *-- big enough to accomodate the three buttons. m->nY = iif(int(m->nMsgLen) > 30,int(m->nMsgLen/2)+2,24) m->nBoxLen = 2 * m->nY *-- Setup the window and determine if shadow ... if yes, call shadow define window wDialog from int(m->nMaxLine/2)-5,40-m->nY to ; int(m->nMaxLine/2)+4,40+m->nY &cBorder. if m->lShadow activate screen do shadow with int(m->nMaxLine/2)-5,40-m->nY,; int(m->nMaxLine/2)+4,40+m->nY endif activate window wDialog clear *-- Determine the type of buttons and set appropriate parms. *-- These could be modified to your own needs. do case case m->nType = 0 m->nNumButton = 1 aButton[1] = " OK " case m->nType = 1 m->nNumButton = 2 aButton[1] = " OK " aButton[2] = " CANCEL " case m->nType = 2 m->nNumButton = 3 aButton[1] = " ABORT " aButton[2] = " RETRY " aButton[3] = " IGNORE " case m->nType = 3 m->nNumButton = 3 aButton[1] = " YES " aButton[2] = " NO " aButton[3] = " CANCEL " case m->nType = 4 m->nNumButton = 2 aButton[1] = " YES " aButton[2] = " NO " case m->nType = 5 m->nNumButton = 2 aButton[1] = " RETRY " aButton[2] = " CANCEL " endcase *-- Get dialog box length to create a bar menu of appropriate size. *-- Define the bar menu in a loop. Deactivate it upon selection of *-- one of the buttons. m->nCounter = 1 m->nBaseX = m->nBoxLen / (m->nNumButton + 1) define menu mDialog do while m->nCounter <= m->nNumButton pPadName = "PAD"+str(m->nCounter,1) && pad name is 'PAD #' m->nYCol = (m->nCounter * m->nBaseX) - ; (int(len(aButton[m->nCounter]) /2)) define pad &pPadName. of mDialog prompt aButton[m->nCounter] ; at 4,m->nYCol *-- If shadow is on, put shadows on buttons as well ... if m->lShadow activate screen do shadow with 3,m->nYCol-2,5,m->nYCol+; (len(aButton[m->nCounter]))-1 endif @3,m->nYCol-1 to 5,m->nYCol+(len(aButton[m->nCounter])) && box around button on selection pad &pPadName. of mDialog deactivate menu m->nCounter = m->nCounter + 1 enddo *-- place message (centered in box) m->nMsgLoc = int(m->nBoxLen/2) - int(m->nMsgLen/2) @1,m->nMsgLoc say m->cMsg *-- place cursor to the default button specified by the user m->nCounter = 1 do while m->nCounter < m->nDefBut keyboard chr(4) m->nCounter = m->nCounter + 1 enddo *-- Activate the whole thing, and return the button name activate menu mDialog m->cValue = trim(ltrim(prompt())) *-- deactivate it all, restore screen, etc. release window wDialog release menu mDialog restore screen from sDialog release screen sDialog do ReColor with m->cCurColor on key label tab RETURN m->cValue *-- EoF: Dialog() FUNCTION MsgExp *----------------------------------------------------------------------- *-- Programmer..: Adam Menkes (Borland) *-- Date........: 02/05/1993 *-- Notes.......: Allows you to display message (or error message), *-- centered like SET MESSAGE ... with added utility. Does *-- not use "(Press Space)", which can be annoying. The *-- message and the line on which it is displayed will be *-- the same color. Taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 09/01/1991 -- Original routine *-- 02/05/1993 -- Modified by Lee Hite to handle a string *-- that is greater than 80 characters (this *-- can be a real problem if the message is *-- in row 24!) *-- Usage.......: MsgExp("<cExp>") *-- Example.....: MsgExp("This is a message") *-- Returns.....: Message displayed (centered) on screen *-- Parameters..: cExp = Message to be displayed *----------------------------------------------------------------------- parameters cMsg private nLen m->nLen = (80-len(trim(m->cMsg)))/2 RETURN space(m->nLen) + trim(m->cMsg) + space(m->nLen+0.5) *-- EoF: MsgExp FUNCTION YesNoCan *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 02/01/1993 *-- Notes.......: Asks a yes/no/cancel question in a dialog window/box *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a *-- function *-- 04/29/1991 - Modified to Ken Mayer add shadow *-- 05/13/1991 - Modified to Ken Mayer remove need for *-- extra procedures (YES/NO) that were used *-- for returning values from Menu *-- (suggested by Clinton L. Warren (VBCES)) *-- 01/20/1992 - Modified by Martin Leon (HMan) to handle *-- user pressing 'Y' or 'N' keys (with ON *-- KEY ...). *-- 06/11/1992 - Modified by Joey Carroll (JOEY) to allow *-- answer choices to be "Yes", "No", or *-- "Cancel" or to allow for parameters to *-- pass the contents of the prompts. If none *-- are passed, they default to "Yes", "No", *-- "Cancel". Further modified to allow *-- specification of location by row if *-- desired. Window size now varies as *-- parameters dictate. *-- 09/21/1992 - Modified by JOEY to fix bug caused if *-- leading blanks in parameters cPrompt1, *-- cPrompt2,cPrompt3. Corrected example - *-- case pad()="PPAD1" instead of case *-- pad()=PPAD1 *-- 02/01/1993 - Mods by Lee Hite: Routine would not wait *-- for user response if "default" answer *-- did not match one of the prompts. Now *-- first prompt becomes default if no match *-- is found on invocation. Also, match is no *-- longer case sensitive. Also made window *-- height variable if message lines 2 and/or *-- 3 are null strings. Finally, added *-- "confirmation" parameter which when set *-- true will force user to press [Enter] *-- before function returns. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- ISBLANK() Function in MISC.PRG, Internal in 1.5 *-- Called by...: Any *-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>",; *-- "<cMess3>","<cPrompt1>","<cPrompt2>",; *-- "<cPrompt3>",<nTopRow>,"<cColor>",[lConfirm]) *-- Example.....: cAnswer="Y" *-- cAnswer=YesNoCan(cAnswer,"*** Warning ***",; *-- "A serious error has occured.",; *-- "Choose carefully.","Proceed",; *-- "Retry","Cancel",10,; *-- "w+/r,n/w,w+/r") *-- do case *-- case cAnswer="Y" && OR case pad()="PPAD1" *-- * do your thing *-- case cAnswer="N" && OR case pad()="PPAD2" *-- skip *-- case cAnswer="C" && OR case pad()="PPAD3" *-- * e.g. - return *-- endcase *-- *-- The middle set of colors should be different, as *-- they will be the colors of the YES/NO selections ... *-- Options may be blank by using nul values ("") *-- Returns.....: First character of selected pad *-- Parameters..: cAnswer = default value (Yes or No or Cancel) for *-- menu *-- cMess1 = First line of Message *-- cMess2 = Second line of message *-- cMess3 = Third line of message *-- cPrompt1 = Optional prompt for left pad *-- cPrompt2 = Optional prompt for middle pad *-- cPrompt3 = Optional prompt for right pad *-- nTopRow = Optional top row of window *-- cColor = Optional colors for window/menu/box *-- lConfirm = Optional "confirmation" parameter -- if *-- true user must press [Enter], otherwise *-- pressing a valid prompt key automatically *-- returns *----------------------------------------------------------------------- parameter cAnswer,cMess1,cMess2,cMess3,; cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,; nWinWidth,cConfirm, nWinHgth, nMsgRow private cPrompt1,cPrompt2,cPrompt3 *-- save screen so we can restore ... save screen to sYesNoCan * locate top row of window m->nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line m->nTopRow = iif(isblank(m->nTopRow),14,m->nTopRow) && no parameter passed m->nTopRow = min(m->nTopRowMax,m->nTopRow) * set pad prompts if none passed m->cPrompt1 = iif(isblank(m->cPrompt1),"Yes",m->cPrompt1) m->cPrompt2 = iif(isblank(m->cPrompt2),"No",m->cPrompt2) m->cPrompt3 = iif(isblank(m->cPrompt3),"Cancel",m->cPrompt3) m->cAnswer = iif(isblank(m->cAnswer),m->cPrompt1,m->cAnswer) * program bombs if prompts passed contain leading blanks m->cPrompt1 = ltrim(trim(m->cPrompt1)) m->cPrompt2 = ltrim(trim(m->cPrompt2)) m->cPrompt3 = ltrim(trim(m->cPrompt3)) * determine how wide the window needs to be m->nWinWidth = max(19,len(m->cPrompt1 + m->cPrompt2 + m->cPrompt3); +13) m->nWinWidth = max(m->nWinWidth,len(cMess1)+4) m->nWinWidth = max(m->nWinWidth,len(cMess2)+4) m->nWinWidth = max(m->nWinWidth,len(cMess3)+4) * and how high it needs to be m->nWinHgth = iif(""=m->cMess2,7,8) m->nWinHgth = iif(""=m->cMess3,m->nWinHgth-1,m->nWinHgth) * and center it define window wYesNoCan from m->nTopRow,40-(m->nWinWidth+2)/2 ; to m->nTopRow+m->nWinHgth-1,40+(m->nWinWidth+2)/2 ; double color &cColor. define menu mYesNoCan define pad pPad1 of mYesNoCan Prompt "["+m->cPrompt1+"]" ; at m->nWinHgth-3,02 * center middle prompt between other two, not center of window define pad pPad2 of mYesNoCan Prompt "["+m->cPrompt2+"]" at ; m->nWinHgth-3, ((m->nWinWidth-len(m->cPrompt2))/2+; (len(m->cPrompt1)-len(m->cPrompt3))/2) define pad pPad3 of mYesNoCan Prompt "["+m->cPrompt3+"]" ; at m->nWinHgth-3,(m->nWinWidth-3)-(len(m->cPrompt3)) on selection pad pPad1 of mYesNoCan deactivate menu on selection pad pPad2 of mYesNoCan deactivate menu on selection pad pPad3 of mYesNoCan deactivate menu activate screen do shadow with m->nTopRow,40-(m->nWinWidth+2)/2,m->nTopRow+; m->nWinHgth-1,40+(m->nWinWidth+2)/2 activate window wYesNoCan do center with 0,m->nWinWidth,"",cMess1 && center the text *-- deal with blank message lines m->nMsgRow = 2 if "" <> m->cMess2 do center with m->nMsgRow,m->nWinWidth,"",m->cMess2 m->nMsgRow = m->nMsgRow + 1 endif if "" <> m->cMess3 do center with m->nMsgRow,m->nWinWidth,"",m->cMess3 endif *-- deal with user pressing first key of prompt m->cKey1 = left(m->cPrompt1,1) m->cKey2 = left(m->cPrompt2,1) m->cKey3 = left(m->cPrompt3,1) *-- set [CR] at end of keyboard command depending on "confirm" *-- parameter m->cConfirm = iif(m->lConfirm,"",chr(13)) on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ; iif(pad() = "PPAD2", chr(19),CHR(4) )) + m->cConfirm on key label &cKey2. keyboard iif( PAD() = "PPAD2", "", ; iif(pad() = "PPAD1",CHR(4),chr(19) )) + m->cConfirm on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ; iif(pad() = "PPAD2", CHR(4),chr(19))) + m->cConfirm clear typeahead *-- otherwise deal with regular "menu" abilities do case case upper(m->cAnswer)=upper(m->cKey1) activate menu mYesNoCan pad pPad1 case upper(m->cAnswer)=upper(m->cKey2) activate menu mYesNoCan pad pPad2 case upper(m->cAnswer)=upper(m->cKey3) activate menu mYesNoCan pad pPad3 otherwise activate menu mYesNoCan pad pPad1 endcase *-- clear out ON KEY settings ... on key label &cKey1. on key label &cKey2. on key label &cKey3. *-- reset environment release window wYesNoCan restore screen from sYesNoCan release screen sYesNoCan release menu mYesNoCan RETURN upper(substr(prompt(),2,1)) *-- EoF: YesNoCan() PROCEDURE ProgBar2 *----------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY) *-- Date........: 10/26/1992 *-- Notes.......: A crippled version of PROGBAR for those who want it *-- simple. A visual indicator of program activity, i.e. *-- shows user program didn't die during long processes *-- which do not normally show 'on screen'. Serves same *-- purpose as MONITOR, but is more graphic. *-- For best appearance, set cursor 'off' from calling *-- program, outside of the loop which calls PROGBAR. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/28/1992 -- Original *-- 10/26/1992 -- protected existing active window. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PROGBAR2 with <nQuan>,<cWindCol>,<cFillCol1>,; *-- <cFillCol2> *-- Example.....: *-- determine what process will be monitored and what *-- *-- the final value will be, e.g. nReccount = *-- *-- reccount() *-- use <anyfile> *-- nReccount = reccount() *-- set cursor off *-- scan *-- do progbar2 with nReccount,",,w+/n","w+/r","w+/g" *-- *-- do some needed process here *-- endscan *-- *-- cleanup *-- Returns.....: None *-- Parameters..: nQuan = maximum number of iterations *-- cWindCol = the window colors *-- cFillCol1 = color of ruler before process *-- cFillCol2 = color of ruler after process *----------------------------------------------------------------------- parameters nQuan,cWindCol,cFillCol1,cFillCol2 private nWindWidth m->nWindWidth = 78 && hard coded, wall to wall *-- skip this section if we've been here before *-- this procedure called from inside a loop *-- following section ignored except on first iteration thru loop if type("nTimes") = "U" save screen to sProgBar public m->nFactor,m->nTimes,wPrevWind wPrevWind = window() if set("status") = "ON" && different location if status "on" define window wProgBar from 19,0 to 21,79 double ; color &cWindCol. else define window wProgBar from 21,0 to 23,79 double ; color &cWindCol. endif && set("status") = "ON" activate window wProgBar @ 0,0 say replicate(".",m->nWindWidth - 1) && the ruler @ 0,0 say "0%" && and some gradation %'s @ 0,m->nWindWidth / 4 - 2 say "25%" @ 0,m->nWindWidth / 2 - 2 say "50%" @ 0,3*(m->nWindWidth / 4) - 2 say "75%" @ 0,m->nWindWidth - 4 say "100%" @ 0,0 fill to 0,m->nWindWidth - 1 color &cFillCol1. && color of ruler before process m->nFactor = m->nQuan/m->nWindWidth && e.g. how many records per bar part(cols) m->nTimes = 0 && times thru loop endif && type("nTimes") = "U" *-- the section will be processed as many times as required by nQuan m->nTimes = m->nTimes+1 @ 0,0 fill to 0,int(m->nTimes/m->nFactor) ; - iif(int(m->nTimes/m->nFactor) -1 >= 0,1,0) ; color &cFillCol2. && color of ruler as processing takes place if m->nTimes = m->nQuan && we done m->x = inkey(.5) && leave on screen just a liitle while && after completion * cleanup your mess release window wProgBar restore screen from sProgBar release screen sProgBar *-- if window was active, re-activate if .not. isblank(wPrevWind) activate window &wPrevWind. endif release nProgBar,m->nFactor,m->nTimes,m->nWindWidth,m->x,wPrevWind endif RETURN *-- EoP: PROGBAR2 PROCEDURE MovePad *----------------------------------------------------------------------- *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223) *-- Date........: 07/29/1992 *-- Notes.......: Used to move the selected pad in a dBASE Bar Menu if *-- the user selects the first letter/key of the pad. The *-- routine doesn't re-evalute PAD(), and is based on *-- Genifer code (improved on by Angus). This should be *-- used with the ON KEY command. *-- NOTE: This routine assumes you are using the *-- dUFLP/dHUNG standard for naming pads, and that the *-- first character of each pad NAME is 'p' (i.e., pColor, *-- pExit, etc.). *-- Written for.: dBASE IV, 1.5, should work in 1.1. *-- Rev. History: 07/24/1992 -- Original *-- 07/29/1992 -- Added header/notes. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do MovePad with <cLetter>,<lSelect>,<cChoices> *-- Example.....: on key label "C" do MovePad with "C",.t.,cChoices *-- Returns.....: None *-- Parameters..: cLetter = first letter/key on pad *-- lSelect = select pad, or move cursor to it? (Act as *-- if user pressed <Enter> after moving *-- to it) *-- cChoices = list of possible choices (i.e., *-- "Enter,Edit,Delete,Print,Exit") *----------------------------------------------------------------------- parameters cLetter, lSelect, cChoices private nToMove *-- determine how many pads to move, based on position of choice in *-- list of choices (m->cChoices). m->nToMove = at(m->cLetter,m->cChoices) - ; at(substr(pad(),2,1),m->cChoices) *-- if it is a negative value, move to the left, and press <Enter> if *-- lSelect = .t. (otherwise, just move there and stop). if m->nToMove < 0 keyboard replicate(chr(5), -m->nToMove) + ; iif(m->lSelect,chr(13),"") else keyboard replicate(chr(24), m->nToMove) + ; iif(m->lSelect,chr(13),"") endif RETURN *-- EoP: MovePad PROCEDURE Monitor *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 06/08/1992 *-- Notes.......: Displays a status message to monitor a long-running *-- operation that operates on multiple records . . . *-- Should be used with MONITOROFF (below) to cleanup. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow *-- 06/08/1992 - Modified to handle explicit color setting *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: do monitor with "<cText>","<cColor>" *-- Example.....: do monitor with "Processing REPORT.DBF",; *-- "rg+/gb,rg+/gb,rg+/gb" *-- nRec = 0 *-- do while && (or SCAN) *-- && stuff -- process records *-- nRec = nRec + 1 *-- @4,30 display ltrim(str(nRec)) && current record *-- && in window MONITOR *-- enddo && (or endscan) *-- do MonitorOff && procedure to clean-up after this one *-- Returns.....: None *-- Parameters..: cText = Text to display *-- cColor = Colors for window *----------------------------------------------------------------------- parameters cText,cColor private cTempCol save screen to sMonitor activate screen define window wMonitor From 10,10 to 18,70 double color &cColor. do shadow with 10,10,18,70 activate window wMonitor do center with 1,60,"",m->cText do center with 2,60,"","Please do not interrupt" @4,10 say "Working on record of " + ltrim(str(reccount(),5)) RETURN *-- EoP: Monitor PROCEDURE MonitorOff *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/23/1991 *-- Notes.......: Used to deal with ending routines for MONITOR *-- procedure above. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 -- Original *-- Calls.......: None *-- Called by...: Routine using MONITOR Procedure in PROC.PRG *-- Usage.......: do monitoroff *-- Example.....: do monitoroff *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- release window wMonitor restore screen from sMonitor release screen sMonitor RETURN *-- EoP: MonitorOff FUNCTION NewBorder *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 01/20/1993 *-- Notes.......: Will save current border setting (the returned value), *-- and set a new one with one of a set of pre-defined *-- borders. This will create a new variable if it doesn't *-- already exist, called: c_Border, which is a PUBLIC *-- Character variable. The purpose is so that you can *-- keep using this string for other purpose (i.e., *-- DEFINE WINDOW and such ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/20/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: NewBorder("<cStyle>") *-- Example.....: cOldBorder = NewBorder("K") *-- @5,10 to 15,60 && draw box with new "border" setting *-- *-- define a window with new "border" setting *-- define window wTest from 10,20 to 20,60 &c_Border *-- set border to &cOldBorder && reset border to original *-- Returns.....: Current border setting (before calling routine) *-- Parameters..: cStyle = Style from one of the following: *-- A = Double *-- …ÕÕÕÕª *-- ∫ ∫ *-- »ÕÕÕÕº *-- B = Single *-- ⁄ƒƒƒƒø *-- ≥ ≥ *-- ¿ƒƒƒƒŸ *-- C = Panel *-- €€€€€€ *-- € € *-- €€€€€€ *-- D = None *-- E = Double Top, Single Left, Right, and *-- Bottom *-- ’ÕÕÕÕ∏ *-- ≥ ≥ *-- ¿ƒƒƒƒŸ *-- F = Single Top, Double Left, Right and Bottom *-- ÷ƒƒƒƒ∑ *-- ∫ ∫ *-- »ÕÕÕÕº *-- G = Double Top, Left, Right, Single Bottom *-- …ÕÕÕÕª *-- ∫ ∫ *-- ”ƒƒƒƒΩ *-- H = Single Top, Left, Right, Double Bottom *-- ⁄ƒƒƒƒø *-- ≥ ≥ *-- ‘ÕÕÕÕæ *-- I = Double Top, Single Left and Right, *-- Double Bottom *-- ’ÕÕÕÕ∏ *-- ≥ ≥ *-- ‘ÕÕÕÕæ *-- J = Single Top, Double Left and Right, *-- Single Bottom *-- ÷ƒƒƒƒ∑ *-- ∫ ∫ *-- ”ƒƒƒƒΩ *-- K = Single Top and Left, Double Right and *-- Bottom *-- ⁄ƒƒƒƒ∑ *-- ≥ ∫ *-- ‘ÕÕÕÕº *-- L = Single Top, Double Left, Single Right, *-- Double Bottom *-- ÷ƒƒƒƒø *-- ∫ ≥ *-- »ÕÕÕÕæ *-- M = Double Top and Left, Single Right and *-- Bottom *-- …ÕÕÕÕ∏ *-- ∫ ≥ *-- ”ƒƒƒƒŸ *-- N = Double Top, Single Left, Double Right, *-- Single Bottom *-- ’ÕÕÕÕª *-- ≥ ∫ *-- ¿ƒƒƒƒΩ *-- O = Double Top, Single Left, Double Right *-- and Bottom *-- ’ÕÕÕÕª *-- ≥ ∫ *-- ‘ÕÕÕÕº *-- P = Double Top, Left, Single Right, *-- Double Bottom *-- …ÕÕÕÕÕ∏ *-- ∫ ≥ *-- »ÕÕÕÕÕæ *-- Q = Single Top, Double Left, Single Right *-- and Bottom *-- ÷ƒƒƒƒƒø *-- ∫ ≥ *-- ”ƒƒƒƒƒŸ *-- R = Single Top and Left, Double Right, *-- Single Bottom *-- ⁄ƒƒƒƒƒ∑ *-- ≥ ∫ *-- ¿ƒƒƒƒƒΩ *-- S = Panel, but with more room on the *-- interior ... the default 'panel' mode *-- for borders uses uses 220-223 ... *-- ﬁﬂﬂﬂﬂﬂ› *-- ﬁ › *-- ﬁ‹‹‹‹‹› *----------------------------------------------------------------------- parameters cStyle m->cReturn = set("BORDER") && current border -- if version of dBASE && is less than 1.5, comment this out ... if type("c_Border") = "U" && if this is undefined public m->c_Border && declare it as public endif *-- here we go ... do case case m->cStyle = "A" m->c_Border = "DOUBLE" && pre-defined case m->cStyle = "B" m->c_Border = "SINGLE" && pre-defined case m->cStyle = "C" m->c_Border = "PANEL" && pre-defined case m->cStyle = "D" m->c_Border = "NONE" && pre-defined case m->cStyle = "E" *-- items are: top line, bottom line, left line, right line, *-- upper left corner, upper right corner, bottom left corner, *-- bottom right corner m->c_Border = "205,196,179,179,213,184,192,217" case m->cStyle = "F" m->c_Border = "196,205,186,186,214,183,200,188" case m->cStyle = "G" m->c_Border = "205,196,186,186,201,187,211,189" case m->cStyle = "H" m->c_Border = "196,205,179,179,218,191,212,190" case m->cStyle = "I" m->c_Border = "205,205,179,179,213,184,212,190" case m->cStyle = "J" m->c_Border = "196,196,186,186,214,183,211,189" case m->cStyle = "K" m->c_Border = "196,205,179,186,218,183,212,188" case m->cStyle = "L" m->c_Border = "196,205,186,179,214,191,200,190" case m->cStyle = "M" m->c_Border = "205,196,186,179,201,184,211,217" case m->cStyle = "N" m->c_Border = "205,196,179,186,213,187,192,189" case m->cStyle = "O" m->c_Border = "205,205,179,186,213,187,212,188" case m->cStyle = "P" m->c_Border = "205,205,186,179,201,184,200,190" case m->cStyle = "Q" m->c_Border = "196,196,186,179,214,191,211,217" case m->cStyle = "R" m->c_Border = "196,196,179,186,218,183,192,189" case m->cStyle = "S" m->c_Border = "223,220,222,221,222,221,222,221" endcase set border to &c_Border. RETURN m->cReturn *-- EoF: NewBorder FUNCTION VidRow *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 01/28/1993 *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, *-- CIS: 72147,2635) to return the ABSOLUTE position of *-- the current ROW on the screen, despite any active *-- windows, etc. This is based on original routines by *-- David Frankenbach, but includes the load/release in *-- one routine, rather than requiring three functions *-- to perform this ... *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/28/1993 -- Original *-- Calls.......: VDCURSOR.BIN *-- Called by...: Any *-- Usage.......: VidRow() *-- Example.....: ?VidRow() *-- Returns.....: Numeric ROW position for current row on screen *-- Parameters..: None *----------------------------------------------------------------------- private cX m->cX = space(2) && define argument memvar load vdcursor && load the .BIN file call vdcursor with m->cX && call it with the memvar release module vdcursor && release from memory RETURN (asc(substr(m->cX,2))-1) *-- && return the value of the absolute cursor position *-- EoF: VidRow() FUNCTION VidCol *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 01/28/1993 *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, *-- CIS: 72147,2635) to return the ABSOLUTE position of *-- the current COLUMN on the screen, despite any active *-- windows, etc. This is based on original routines by *-- David Frankenbach, but includes the load/release in *-- one routine, rather than requiring three functions to *-- perform this ... *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/28/1993 -- Original *-- Calls.......: VDCURSOR.BIN *-- Called by...: Any *-- Usage.......: VidCol() *-- Example.....: ?VidCol() *-- Returns.....: Numeric COLUMN position for current Col on screen *-- Parameters..: None *----------------------------------------------------------------------- private cX m->cX = space(2) && define argument memvar load vdcursor && load the .BIN file call vdcursor with m->cX && call it with the memvar release module vdcursor && release from memory RETURN (asc(substr(m->cX,1))-1) *-- && return the value of the absolute cursor position *-- EoF: VidCol() FUNCTION PwdMask *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 01/29/1993 *-- Notes.......: Designed to display a mask on the screen when a user *-- is entering a password, rather than a blank surface. *-- Should handle backspaces to delete ... ASSUMES *-- <cField> is a memvar. *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/29/1993 -- Original *-- Calls.......: VidRow() Function in SCREEN.PRG *-- VidCol() Function in SCREEN.PRG *-- Called by...: Any *-- Usage.......: PwdMask("<cField>"[,<nMaskChar>]) *-- Example.....: @5,10 get password when PwdMask("Password"); *-- valid required .not. isblank(password); *-- error chr(7)+"Password cannot be blank) *-- Returns.....: .T., and field will have password placed in it when *-- done. *-- Parameters..: cField = name of the field *-- nMaskChar = ASCII code for mask character. *-- OPTIONAL parameter. *-- If not provided, will use asterisk. *-- Suggested characters include: *-- 176,177,178,219,248,249,254 *-- ∞ ± ≤ € ¯ ˘ ˛ *----------------------------------------------------------------------- parameters cField, nMaskChar private nLength, nChar, nX *-- deal with mask character if type("NMASKCHAR") = "L" m->nMaskChar = 42 && * endif m->lCursor = set("CURSOR") = "ON" set cursor off && rather than have the cursor in the way ... m->nLength = len(&cField.) && get length of current field m->nChar = 0 && input character m->nRow = vidrow() && get absolute cursor location m->nCol = vidcol() && ditto m->cTemp = "" && initialize temp memvar do while len(m->cTemp) < m->nLength .and. m->nChar # 13 && loop until we hit end of field && or user presses <Enter> m->nChar = inkey(0) && wait for user to enter something do case case m->nChar = 127 && <BackSpace> if isblank(m->cTemp) && if empty, don't delete anything ?? chr(7) && instead, BEEP else m->cTemp = left(m->cTemp,len(m->cTemp)-1) && backup one endif case (m->nChar => 65 .and. m->nChar <= 90) .or.; (m->nChar => 97 .and. m->nChar <= 122) && alphabetic input only m->cTemp = m->cTemp + chr(m->nChar) && add character case m->nChar = 13 && <Enter> exit otherwise ?? chr(7) && otherwise, BEEP loop endcase *-- create the current "mask", padding with spaces ... m->cMask = replicate(chr(m->nMaskChar),len(m->cTemp)) +; space(m->nLength-len(m->cTemp)) *-- display it in same color as the current "GET" @m->nRow,m->nCol get m->cMask clear gets *-- put password into current memvar store m->cTemp to &cField. enddo *-- turn cursor on if it was prior to this routine if m->lCursor set cursor on endif keyboard chr(13) && send a final <Enter> to exit this GET RETURN .T. *-- EoF: PwdMask() PROCEDURE MultiPick *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/06/1993 *-- Notes.......: Permits selecting 0 or more elements of an array. *-- The array must contain two columns, the first of which *-- contains the prompt for the row and the second of *-- which contains logical .T. if the row is selected by *-- default, or .F. Array may contain additional columns. *-- This is written for programmers, not end users. *-- It assumes the active window and border style are set *-- before it is called, and no error handling is provided *-- for attempts to write outside the current window, *-- impossible colors, truncation of prompts or other *-- calling errors that should become evident on testing. *-- *-- If array contains elements "Hydrangea",.T. and *-- "Tulip",.F., initial display after setting a window *-- and calling will be something like this: *-- *-- [ ˚ ] Hydrangea *-- [ ] Tulip *-- *-- This program will use the mouse if two conditions *-- exist: *-- 1) The variable nG_MusClic must exist and must *-- hold the inkey() value of the character "keyboarded" *-- for a click by the mouse-event handler. Note that *-- this is often, but need not be, the same as *-- asc( <character> ). *-- 2) The mouse must be made active and visible by a *-- mouse-control .bin such as JPMOUSE.BIN and *-- MUSCLICK.BIN must be loaded and installed. *-- ******************************* *-- **** REQUIRES MUSCLICK.BIN **** *-- **** JPMOUSE.BIN **** *-- **** VDCURSOR.BIN **** *-- ******************************* *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/16/93 - original procedure *-- 02/06/93 - revised to use cWnSize, etc. *-- 02/24/93 - parameters changed, functions called moved *-- out *-- 02/28/93 - symbolic constants and support for tab *-- added *-- Calls.......: SMultPick Child procedure to paint screen *-- Arrayrows() Function in Array.prg *-- MUSCLICK.BIN Binary mouse-event handler *-- CWnSize() Function to find window size *-- CWnDecode() Function to decode the above *-- YnMouse() Yesno function for mouse *-- NormColors() Function to return normal colors *-- HighColors() Function to return highlight colors *-- ForeColor() Function to return foreground color *-- Called by...: Any *-- Usage.......: DO Multipick WITH <cArray>,<nDown>,<nLast>,<nRows>,; *-- <nLength>,<cColors> [, <cCheck> ]] *-- Example.....: DO Multipick WITH "Myarray",3,15,10,18,"RG+/G,N/W",; *-- chr(2) *-- Parameters..: cArray = Name of the array of selectable items. *-- See Notes, above, for required *-- structure. *-- nDown = first useable row of window *-- nLast = last useable row of window *-- nRows = number of items to show on screen at *-- once *-- nLength = maximum length of prompts *-- cColors = optional, colors to use for noncurrent *-- and current items. Default is NORMAL *-- and HIGHLIGHT colors for the current *-- window. Pass default as .F. if cCheck *-- is included. *-- cCheck = optional, character to use to show *-- selection. Default is "˚". See "cBox" *-- variables in the procedure for *-- bracketing characters. *-- Also uses...: global numeric variable nG_MusClic, giving the inkey() *-- value of the character "keyboarded" by a mouse click. *-- If this variable does not exist, mouse support is *-- absent. *-- Side effects: On return, the values of the second column of the *-- array are .T. or .F. in accordance with selections *-- made. *-- Special note: The CWnSize function called by this routine uses *-- VDCURSOR.BIN, which must be available for this routine *-- to work, and disables any ON ERROR trap. *----------------------------------------------------------------------- parameters cArray, nDown, nLast, nRows, nLength, cColors, cCheck private cChar, cCols, cNorm, cHigh, nAt, nTop, nKey, cBoxl, ; cBoxr private nElems, lGotMouse, nMTop, nMBot, nMLeft, nMRight, cCols private cMrow, cMcol, nMrow, nMcol, cEsc, cWin, nWinTop, ; nWinLeft private nWinBot, nWinRight, nK, cK, cTemp, nX, cQuit, nRo, ; lOnPicks private lOk * These "symbolic constants" are C-style, just to avoid "magic * numbers" scattered throughout the routine. Of course, they * may also slow it down absent a true compiler private NBOXLEN, NEXTRAROWS, NPADLEN, NTWOPADS m->nBoxLen = 6 && length of the "[ ˚ ] " structure m->nExtraRows = 4 && blank row at top, 3 rows for quit pads m->nPadLen = 6 && length of the OK and Cancel pads m->nTwoPads = 13 && length of two pads and a space between * set escape m->cEsc = set("ESCAPE") set escape off * set delimiter chars m->cBoxL = "[ " m->cBoxR = " ] " * set colors if specified if type( "cColors" ) = "C" m->cCols = m->cColors else m->cCols = set( "ATTRIBUTES" ) m->cCols = left( m->cCols, at( "&", m->cCols ) - 2 ) endif m->cNorm = NormColors( m->cCols ) m->cHigh = HighColors( m->cCols ) * set up quit pad colors m->cQuit = m->cHigh * set checkmark char, default is "˚" ( chr( 251 ) ) m->cChar = iif( type( "cCheck" ) # "L", m->cCheck, "˚" ) * calculate array rows and set up temporary array for restoration m->nElems = arrayrows( m->cArray ) declare cTemp[ m->nElems ] m->nX = 1 do while m->nX <= m->nElems cTemp[ m->nX ] = &cArray.[ m->nX, 2 ] m->nX = m->nX + 1 enddo * find borders of current window and determine centering offset m->cWin = cWnSize() if len( m->cWin ) > 0 m->nWinTop = cWnDecode( m->cWin, "T" ) m->nWinLeft = cWnDecode( m->cWin, "L" ) m->nWinBot = cWnDecode( m->cWin, "B" ) m->nWinRight = cWnDecode( m->cWin, "R" ) else activate screen ? "Can't find VDCURSOR.BIN - aborting" wait cancel endif m->nRight = int( ( m->nWinRight - m->nWinLeft - m->nBoxLen - ; m->nLength ) / 2 ) m->nCkCol = m->nRight + 2 * we need at least 13 columns for the quit pads, and enough for * the checkbox table itself if m->nWinRight - m->nWinLeft < max( m->nTwoPads, m->nBoxLen + ; m->nLength ) activate screen ? "Too few columns in this window - aborting" wait cancel endif * determine rows to use if window is small m->nRo = min( m->nRows, min( m->nLast - m->nDown, ; m->nWinBot - m->nWinTop - m->nExtraRows ) ) if m->nRo < 1 activate screen ? "Too few rows in this window - aborting" wait cancel endif * test for mouse support and set boundaries of active click area * nMx variables represent absolute screen positions of the edges * of the checkbox table m->lGotMouse = .F. if type( "nG_MusClick" ) = "N" m->lGotMouse = .T. m->nMTop = m->nWinTop + m->nDown - 1 && row above table m->nMLeft = m->nWinLeft + m->nRight && left edge of table m->nMBot = m->nMTop + m->nRo + 1 && row below table m->nMRight = m->nMLeft + m->nBoxLen + m->nLength - 1 && right edge endif * position quit pads ( they are displayed by Smultpick ) * nLpad and nRpad are column offsets within the active window * of the two pads, " OK " and "Cancel" if m->nPadLen + m->nLength > m->nTwoPads m->nLPad = m->nRight else m->nLPad = int( ( m->nWinRight - m->nWinLeft ) / 4 ) -; ( m->nPadLen / 2 ) endif m->nRPad = m->nWinRight - m->nWinLeft - m->nPadLen - m->nLPad * initialize display as if "Home" had been pressed * nTop is the index into the array of the element to be shown * on the top row of the table * nHigh is the index into the array of the element to be shown * highlighted ( the current element ) * lOnPicks is the "focus"; .T. means we are in the pick table, * not on the quit pads m->nTop = 1 m->nHigh = m->nTop keyboard "{Home}" m->lOnPicks = .T. * commence main key-handling loop do while .T. m->nKey = inkey() if m->nKey = 0 loop endif do case case m->nKey = 23 && Ctrl-End exit case m->nKey = 27 && Escape if YesQuit() exit endif case m->nKey = 79 .or. m->nKey = 111 && 'O' or 'o' exit case m->nKey = 67 .or. m->nKey = 99 && 'C' or 'c' if YesQuit() exit endif case m->nKey = 9 && Tab if m->lOnPicks m->lOk = .T. && default tab is "OK" @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR color &cNorm. @ row(), col() say left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ) color &cNorm. @ m->nLast, m->nLPad + m->nPadLen / 2 say "" else do SmultPick endif m->lOnPicks = .not. m->lOnPicks case m->lGotMouse .and. m->nKey = nG_MusClick && mouse click store chr(255) to m->cMRow, m->cMCol call MUSCLICK with m->cMRow, m->cMCol m->nMRow = asc( m->cMRow ) m->nMCol = asc( m->cMCol ) if m->nMRow >= m->nMTop .and. m->nMRow <= m->nMBot .and. ; m->nMCol >= m->nMLeft .and. m->nMCol <= m->nMRight && in active area m->nAt = m->nHigh - m->nTop + m->nMTop + 1 do case case m->nMRow = m->nAt keyboard chr( 13 ) case m->nMRow = m->nMTop keyboard "{PgUp}" case m->nMRow = m->nMBot keyboard "{PgDn}" case m->nMRow > m->nAt do while m->nAt < m->nMRow keyboard "{DNARROW}" m->nAt = m->nAt + 1 enddo case m->nMRow < m->nAt do while m->nAt > m->nMRow keyboard "{UPARROW}" m->nAt = m->nAt - 1 enddo endcase else * if it was on a pad if m->nMRow = m->nWinTop + m->nLast if m->nMCol >= m->nWinLeft + m->nLPad .and.; m->nMCol < m->nWinLeft + ; m->nLPad + m->nPadLen keyboard "O" loop endif if m->nMCol >= m->nWinLeft + m->nRPad .and. ; m->nMCol < m->nWinLeft + ; m->nRPad + m->nPadLen keyboard "C" loop endif endif keyboard "{Esc}" endif otherwise if m->lOnPicks do case case m->nKey = 26 && Home m->nTop = 1 m->nHigh = m->nTop do SMultPick case m->nKey = 2 && End m->nTop = m->nElems - m->nRo + 1 m->nHigh = m->nElems do SMultPick case m->nKey = 24 && down arrow if m->nHigh = m->nTop + m->nRo - 1 .or.; m->nHigh = m->nElems keyboard "{PgDn}" else @ m->nHigh - m->nTop + m->nDown, ; m->nRight say "" @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR ; color &cNorm. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ); color &cNorm. m->nHigh = m->nHigh + 1 @ row() + 1, m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) +m->cBoxR ; color &cHigh. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), ; m->nLength ) color &cHigh. @ row(), m->nCkCol say "" endif case m->nKey = 5 && up arrow if m->nHigh = m->nTop keyboard "{PgUp}" else @ m->nHigh - m->nTop + m->nDown, ; m->nRight say "" @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR ; color &cNorm. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ),; m->nLength ) color &cNorm. m->nHigh = max( 1, m->nHigh - 1 ) @ row() - 1, m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR ; color &cHigh. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ) ; color &cHigh. @ row(), m->nCkCol say "" endif case m->nKey = 32 .or. m->nKey = 13 && space and enter are toggles &cArray.[ m->nHigh, 2 ] = ; .not. &cArray[ m->nHigh, 2 ] @ row(), m->nCkCol say ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) ; color &cHigh. @ row(), m->nCkCol say "" case m->nKey = 3 && PgDn if m->nHigh = m->nTop + m->nRo - 1 .or.; m->nHigh = m->nElems m->nTop = min( m->nHigh, m->nElems - ; m->nRows + 1 ) do SmultPick else @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR ; color &cNorm. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ) ; color &cNorm. m->nHigh = m->nTop + m->nRo - 1 @ m->nDown + m->nRo - 1, m->nRight say "" @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR color &cHigh. @ row(), col() say ; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ); color &cHigh. @ row(), m->nCkCol say "" endif case m->nKey = 18 && PgUp if m->nHigh = m->nTop m->nTop = max( 1, m->nHigh - m->nRo + 1 ) do SmultPick else m->nHigh = m->nTop @ m->nDown, m->nRight say "" @ row(), m->nRight say m->cBoxL + ; iif( &cArray.[ m->nHigh, 2], ; m->cChar, " " ) + m->cBoxR color &cHigh. @ row(), col() say; left( &cArray.[ m->nHigh, 1 ] ; + space( m->nLength ), m->nLength ); color &cHigh. @ row(), m->nCkCol say "" endif endcase else do case case m->nKey = 32 .or. m->nKey = 4 .or. m->nKey = 19 && space, r & l m->lOk = .not. m->lOk @ m->nLast, iif( m->lOk, m->nLPad, m->nRPad ) +; m->nPadLen / 2 say "" case m->nKey = 13 && and enter quits if m->lOk keyboard "{CTRL-END}" else keyboard "{ESC}" endif endcase endif endcase enddo if m->cEsc ="ON" set escape on endif RETURN *-- EoP: MultiPick PROCEDURE SMultPick *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 01/16/1993 *-- Notes.......: Does screen display loop for Multipick procedure. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: Original function 01/16/1993. *-- Calls.......: None *-- Called by...: Multipick *-- Usage.......: DO SMultpick *-- Parameters..: None, but procedure uses various variables set by the *-- parent Multipick procedure. *----------------------------------------------------------------------- private nThisOff, nThisRow, nThisElem, nHiRow, nR m->nThisOff = 0 m->nR = min( m->nRo, m->nElems - m->nTop + 1 ) do while m->nThisOff < m->nRo m->nThisRow = m->nDown + m->nThisOff m->nThisElem = m->nTop + m->nThisOff if m->nThisOff < m->nR if m->nThisElem = m->nHigh @ m->nThisRow, m->nRight say m->cBoxL + ; iif( &cArray.[ m->nThisElem, 2], ; m->cChar, " " ) + m->cBoxR color &cHigh. @ m->nThisRow, col() say ; left( &cArray.[ m->nThisElem, 1 ] ; + space( m->nLength ), m->nLength ) color &cHigh. m->nHiRow = m->nThisRow else @ m->nThisRow, m->nRight say m->cBoxL + ; iif( &cArray.[ m->nThisElem, 2], ; m->cChar, " " ) + m->cBoxR color &cNorm. @ m->nThisRow, col() say ; left( &cArray.[ m->nThisElem, 1 ] ; + space( m->nLength ), m->nLength ) color &cNorm. endif else @ m->nThisRow, m->nRight say space( m->nCkCol + ; len( m->cBoxR ) + m->nLength ) endif m->nThisOff = m->nThisOff + 1 enddo @ m->nLast, m->nLPad say " Done " color &cQuit. @ m->nLast, m->nRPad say "Cancel" color &cQuit. @ m->nHiRow, m->nCkCol say "" RETURN *-- EoP: SMultPick FUNCTION YesQuit *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/24/1993 *-- Notes.......: Asks whether to quit and cancel changes; does so if *-- yes. *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/24/1993 -- Original Release *-- Calls.......: YnMouse() Function in SCREENS.PRG *-- Called by...: Multipick *-- Usage.......: YesQuit() *-- Example.....: ? Yesquit() *-- Parameters..: None *-- Returns.....: Logical, .T. for "Yes" or .F. for "No" *-- Side effects: If "Yes", restores cArray[ , 2 ] values from cTemp *----------------------------------------------------------------------- private nX, lRet lRet = YnMouse( "","Do you wish to restore", ; "the original selection","and leave this routine?" ) if m->lRet m->nX = 1 do while m->nX <= m->nElems &cArray.[ m->nX, 2 ] = cTemp[ m->nX ] m->nX = m->nX + 1 enddo endif RETURN m->lRet *-- EoF: YesQuit() FUNCTION YnMouse *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/28/1993 *-- Notes.......: Returns .T. or .F. answer to question without leaving *-- mouse droppings. Will not respond to left arrow *-- properly unless set( "ESCAPE" ) is off. *-- ******************************* *-- **** REQUIRES MUSCLICK.BIN **** *-- ******************************* *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/23/93 - original function *-- 02/28/93 - revised to support right and left arrows *-- Calls.......: HighColors() Function in COLOR.PRG *-- Center Procedure in PROC.PRG (if centering) *-- Called by...: Any *-- Usage.......: YnMouse( <cColors>, <cP1> [, <cP2>...] [,<lYes>] ) *-- Example.....: ? YnMouse( "", "Are you sure?" ) *-- Parameters..: cColors - String, either blank or holding desired *-- colors as standard ; *-- [,enhanced [,border ]] *-- cP<n> - One or more strings of prompt *-- characters. < only 7 may be passed as *-- literals using dBASE IV 1.5 >. They *-- will be printed one below the other. *-- There may not in any event be more than *-- the number of useable screen rows less *-- 6; the parameters line will have to be *-- changed to use more than 20. *-- As furnished, the justification of the *-- prompt strings is flush left. To center *-- them, see the commented lines in the *-- code. Centering uses the Center *-- procedure in PROC.PRG. *-- lYes - A logical .T. if the default answer is *-- "Yes" This must be the last parameter, *-- but it may follow any number of prompt *-- lines. *-- Returns.....: Logical, .T. for "Yes" or .F. for "No" *----------------------------------------------------------------------- parameters cColors, cP01, cP02, cP03, cP04, cP05, cP06, cP07, ; cP08, cP09, cP10, cP11, cP12, cP13, cP14, cP15, ; cP16, cP17, cP18, cP19, cP20, lYes private cYn, nX, lY, nParams, nRows, nCols, cWhich, nBot, ; nTop, nLeft private cColrs, cPads, nLpad, nRpad, lRet, nScr * obtain number of prompts, and default answer if provided m->nParams = pcount() - 1 m->lY = .F. * if we have 22 parameters, last must be the default answer if m->nParams = 21 m->lY = m->lYes * otherwise look at the last parameter's type--if it is * logical that's the default answer and not a prompt else m->cWhich = "cP" + right( str( 100 + m->nParams ), 2 ) if type( m->cWhich ) = "L" m->lY = &cWhich. m->nParams = m->nParams - 1 endif endif * we need six rows for top and bottom borders, space before * prompts, space after prompts, yes/no pads and space after * them m->nRows = m->nParams + 6 m->nScr = iif( "43" $ set( "DISPLAY" ), 43, 25 ) * don't overwrite messages, status or scoreboard m->nBot = m->nScr - 2 m->nTop = 0 if set( "STATUS" ) = "ON" m->nBot = m->nBot - 2 else if set( "SCOREBOARD" ) = "ON" m->nTop = 1 endif endif if m->nRows > m->nBot - m->nTop activate screen ? "Too many prompt lines for screen size - aborting" wait cancel endif * find longest prompt line and window width it requires * including a space at both ends m->nX = 1 m->nCols = 13 && 11 spaces for the pads, 2 for border do while m->nX <= m->nParams m->cWhich = "cP" + right( str( 100 + m->nX ), 2 ) m->nCols = max( m->nCols, len( trim( &cWhich. ) ) + 2 ) m->nX = m->nX + 1 enddo * round up to even number of columns in order to center the * window m->nCols = 2 * ceiling( m->nCols/ 2 ) if m->nCols > 80 activate screen ? "Prompts are too long for screen - aborting" wait cancel endif * calculate screen row of top and bottom of centered window m->nTop = max( m->nTop, int( ( m->nScr - m->nRows ) / 2 ) ) m->nBot = m->nTop + m->nRows * and screen column of left edge m->nLeft = 39 - m->nCols / 2 * obtain colors to use, using highlight for pads m->cColrs = iif( "" # m->cColors, m->cColors,; set( "ATTRIBUTES" ) ) if "&" $ m->cColrs m->cColrs = left( m->cColrs, at( "&", m->cColrs ) - 1 ) endif m->cPads = HighColors( m->cColrs ) * calculate column positions of yes/no pads m->nLPad = int( ( m->nCols - 2 ) / 4 ) - 2 m->nRPad = m->nCols - m->nLPad - 6 * now open the window and print prompts define window cYn from m->nTop, m->nLeft to m->nBot,; m->nLeft + m->nCols color &cColrs. activate window cYn m->nX = 1 do while m->nX <= m->nParams m->cWhich = "cP" + right( str( 100 + m->nX ), 2 ) * To change from flush left to centered justification of * the prompts, uncomment the next code line and comment out * the one following. * You will then need the "Center" procedure in PROC.PRG. * do Center with nX, nCols, "", &cWhich. @ m->nX, 1 say &cWhich. m->nX = m->nX + 1 enddo * print pads @ m->nX + 1, m->nLPad say " Yes " color &cPads. @ m->nX + 1, m->nRPad say " No " color &cPads. @ m->nX + 1, iif( m->lY, m->nLPad, m->nRPad ) + 2 say "" * and begin a loop that may last forever clear typeahead do while .T. m->nK = inkey() if m->nK = 0 loop endif do case case m->nK = 89 .or. m->nK = 121 && 'Y' or 'y' m->lRet = .T. exit case m->nK = 78 .or. m->nK = 110 .or. m->nK = 27 && 'N' or 'n' or Esc m->lRet = .F. exit case m->nK = 13 .or. m->nK = 23 && Enter or Ctrl-End m->lRet = m->lY exit case m->nK = 4 .or. m->nK = 19 && right or left arrow m->lY = .not. m->lY @ m->nX + 1, iif( m->lY, m->nLPad, m->nRPad ) + 2 ; say "" case type( "nG_MusClic" ) = "N" .and. m->nK = nG_MusClic store chr(255) to m->cMRow, m->cMCol call MUSCLICK with m->cMRow, m->cMCol m->nMRow = asc( m->cMRow ) m->nMCol = asc( m->cMCol ) if m->nMRow = m->nTop + m->nX + 2 && one more for border if m->nMCol >= m->nLPad + m->nLeft .and. ; m->nMCol < m->nLPad + m->nLeft + 5 m->lRet = .T. exit endif if m->nMCol >= m->nRPad + m->nLeft .and. ; m->nMCol <m->nRPad + m->nLeft + 5 m->lRet = .F. exit endif endif endcase enddo deactivate window cYn release window cYn RETURN m->lRet *-- EoF: YnMouse() FUNCTION CWnDecode *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/06/1993 *-- Notes.......: Returns the numeric value of one of the four codes for *-- edges of the window held in a string of the type *-- returned by cWnSize. These represent numbers of rows *-- or columns. *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: 02/06/1993 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: cWnDecode( <cWnString>,<cEdge>|<nPos> ) *-- Example.....: m->cWinTop = cWnDecode( cWin, "T" ) *-- Parameters..: cWnString - A string returned by CWnSize *-- cEdge - A character parameter beginning with one *-- of the four characters "T","L","B",or *-- "R", ( upper or lower case ), OR *-- nPos - A number indicating the position in the *-- cWnString of the code for the edge. *-- These correspond to the following: *-- Window edge cEdge nPos *-- top T 1 *-- left L 2 *-- bottom B 3 *-- right R 4 *-- Either cEdge or nPos must be furnished, *-- not both. *-- Returns.....: numeric value of the row or column; -1 for argument *-- out of range or cWnString holds garbage or is empty. *----------------------------------------------------------------------- parameters cWnString, xEdge private nPos, nRet m->nRet = -1 if type( "xEdge" ) = "C" m->nPos = at( upper( left( m->xEdge, 1 ) ), "TLBR" ) else if type( "xEdge" ) = "N" m->nPos = m->xEdge endif endif if m->nPos > 0 .and. m->nPos < 5 .and. len( m->cWnString ) = 4 m->nRet = asc( substr( m->cWnString, m->nPos, 1 ) ) - 1 endif if m->nRet > iif( mod( m->nPos, 2 ) > 0, 43, 80 ) m->nRet = -1 endif RETURN m->nRet *-- EoF: CWnDecode FUNCTION CWnSize *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/06/1993 *-- Notes.......: Returns a string of four characters which are chr() *-- values of one more each than the top, left, bottom *-- and right row and column numbers of the usable surface *-- of the current window, or of the screen. ( one more *-- to avoid chr( 0 ) problems ) *-- Returns "" if unable to find VDCURSOR.BIN *-- ******************************* *-- **** REQUIRES VDCURSOR.BIN **** *-- ******************************* *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: 02/06/1993 -- Original Release *-- Calls.......: nWBsrch() function included *-- Called by...: Any *-- Usage.......: cWnSize() *-- Example.....: cWin = cWnSize() *-- WinBot = asc( substr( cWin, 3 1 ) ) *-- Parameters..: None *-- Returns.....: character string of four chr() values, or "" if error *-- Side effects: Called function nWBsrch disables any error trap *----------------------------------------------------------------------- private nHi, nLo, nL, cV m->cV = "" if file( "VDCURSOR.BIN" ) load VDCURSOR @ 0,0 say "" m->cV = call( "VDCURSOR"," " ) release module VDCURSOR * reverse bytes so row comes first m->cV = right( m->cV, 1 ) + left( m->cV, 1 ) * this is the first row, and one more than maximum last m->nL = asc( m->cV ) - 1 m->nLo = m->nL m->nHi = 44 m->cV = m->cV + chr( m->nL + nWBsrch( m->nLo, m->nHi, ; "Down" ) + 1 ) * first column and one more than last m->nL = asc( substr( m->cV, 2, 1 ) ) - 1 m->nLo = m->nL m->nHi = 80 m->cV = m->cV + chr( m->nL + nWBsrch( m->nLo, m->nHi, ; "Across" ) + 1 ) endif RETURN m->cV *-- EoF: CWnSize() FUNCTION nWBsrch *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/06/1993 *-- Notes.......: special binary search routine for window edges *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: 02/06/1993 -- Original Release *-- Calls.......: None *-- Called by...: cWnSize *-- Usage.......: nWBsrch( < nLo >, < nHi >, < cDir > ) *-- Example.....: Lastrow = nWBsrch( 0, 44, "Down" ) *-- Parameters..: nLo Number, top row or left column *-- nHi Number, bottom or right screen edge + 1 *-- cDir char, direction - "Down" or "Across" *-- Returns.....: number of highest row or column that may be written to *-- Side effects: Disables any ON ERROR trap *----------------------------------------------------------------------- parameters nLo, nHi, cDir private lToohigh, nTry, cD m->cD = upper( left( m->cDir, 1 ) ) do while m->nHi > m->nLo + 1 m->lTooHigh = .F. m->nTry = int( ( m->nHi + m->nLo ) / 2 ) on error m->lTooHigh = .T. if m->cD $ "DB" @ m->nTry, 0 say "" else @ 0, m->nTry say "" endif if m->lTooHigh m->nHi = m->nTry - 1 else m->nLo = m->nTry endif enddo on error RETURN m->nLo *-- EoF(): nWBsrch PROCEDURE SetBorder *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 03/22/1993 *-- Notes.......: This routine is designed as a front-end for the *-- NEWBORDR routine. It's purpose is to display a sample *-- of the specific border from a picklist, and allow the *-- user to select one ... *-- Written for.: dBASE IV, 2.0 *-- Rev. History: 03/22/1993 *-- Calls.......: NEWBORDR() (Function in SCREEN.PRG) *-- SHADOW (Procedure in PROC.PRG) *-- DRAWIT (Procedure in SCREEN.PRG) *-- Called by...: Any *-- Usage.......: Do SetBordr with <cColor> *-- Example.....: Do SetBordr with cWind1 *-- Returns.....: None *-- Parameters..: cColor = colors for window ... *----------------------------------------------------------------------- parameters cColor private cWindow,cBorder,cHigh *-- start off with a few basics save screen to sBorder && save screen so we can cleanup m->cWindow = window() && save current window (if any) activate screen m->cBorder = set("BORDER") && save current border setting, in && case user doesn't select one ... *-- define a window ... note that we're using the current default *-- border define window wBorder from 5,5 to 15,70 color &cColor. do shadow with 5,5,15,70 activate window wBorder m->cHigh = colorbrk(m->cColor,2) @0,40 fill to 8,60 color &cHigh. @0,40 to 8,60 color &cHigh. @4,45 say "Test Area" color &cHigh. *-- create the popup ... define popup pBorders from 0,0 define bar 1 of pBorders prompt "A) Double" define bar 2 of pBorders prompt "B) Single" define bar 3 of pBorders prompt "C) Panel (Normal)" define bar 4 of pBorders prompt "D) None" define bar 5 of pBorders prompt "E) Double Top, Single Rest" define bar 6 of pBorders prompt "F) Single Top, Double Rest" define bar 7 of pBorders prompt "G) Single Bottom, Double Rest" define bar 8 of pBorders prompt "H) Double Bottom, Single Rest" define bar 9 of pBorders prompt "I) Double Top/Bottom, Single Rest" define bar 10 of pBorders prompt "J) Single Top/Bottom, Double Rest" define bar 11 of pBorders prompt "K) Single Top/Left, Double Rest" define bar 12 of pBorders prompt "L) Single Top/Right, Double Rest" define bar 13 of pBorders prompt "M) Double Top/Left, Single Rest" define bar 14 of pBorders prompt "N) Double Top/Right, Single Rest" define bar 15 of pBorders prompt "O) Single Left, Double Rest" define bar 16 of pBorders prompt "P) Single Right, Double Rest" define bar 17 of pBorders prompt "Q) Double Left, Single Rest" define bar 18 of pBorders prompt "R) Double Right, Single Rest" define bar 19 of pBorders prompt "S) Panel (Thin)" on popup pBorders do drawit on selection popup pBorders deactivate popup *-- Now to play inside the window activate popup pBorders *-- if user didn't select _anything_, then return to original ... if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19 set border to &cBorder. m->c_Border = m->cBorder endif *-- cleanup release window wBorder release popup pBorders restore screen from sBorder release screens Border RETURN *-- EoP: SetBorder PROCEDURE DrawIt *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 03/22/1993 *-- Notes.......: Used specifically with SETBORDER above, to display the *-- current selection from the popup. *-- Written for.: dBASE IV, 2.0 *-- Rev. History: 03/22/1993 -- Original *-- Calls.......: NewBorder() Function in SCREEN.PRG *-- Called by...: SetBorder Procedure in SCREEN.PRG *-- Usage.......: Do DrawIt *-- Example.....: Do DrawIt *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- m->cStyle = left(Prompt(),1) m->x = NewBorder(m->cStyle) if m->c_Border = "SINGLE" set border to single endif if m->c_Border = "NONE" @0,40 say space(21) color &cHigh. @8,40 say space(21) color &cHigh. m->nCounter = 0 do while m->nCounter < 8 m->nCounter = m->nCounter + 1 @m->nCounter,40 say space(1) color &cHigh. @m->nCounter,60 say space(1) color &cHigh. enddo else @0,40 to 8,60 color &cHigh. endif RETURN *-- EoP: DrawIt FUNCTION Wait4Key *----------------------------------------------------------------------- *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223) *-- Date........: 08/18/1993 *-- Notes.......: Time-out option for a READ screen. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 03/24/1993 -- Original *-- 08/18/1993 -- Minor change based on problems with *-- negative value keys (like the function *-- keys). Suggested by >Zak<. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: @x,y GET <fieldname> when Wait4Key(<nSeconds>) *-- Example.....: @10,10 get m->cTest when Wait4Key(5) *-- Returns.....: logical -- .t. if key pressed within nSeconds, .f. if *-- not. *-- Parameters..: nSeconds = how long to wait for time-out. *----------------------------------------------------------------------- parameters nSeconds private nDummy, lKeyPressd m->nDummy = inkey(m->nSeconds) if m->nDummy = 0 && no keypress *-- abort the read keyboard chr(27) && send an <Esc> m->lKeyPressd = .f. else *-- keyboard the character keyboard chr(max(0,m->nDummy)) m->lKeyPressd = .t. endif RETURN m->lKeyPressd *-- EoF: Wait4Key() PROCEDURE JazFill *----------------------------------------------------------------------- *-- Programmer..: Rick Price (HAMMETT) *-- Date........: 05/15/1993 *-- Notes.......: Original is used to fill the screen with chr(176) from *-- the middle out. Thiss is modified (see below) to work *-- on a specific portion of the screen. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/24/1991 -- Original release *-- 05/24/1993 -- Updated by Peter Stevens as an *-- adaptation of JAZCLEAR -- This version can be *-- used to fill a section of the screen with the *-- ASCII chr(176) character. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do jazfill with <nBegRow>,<nBegCol>,<nEndRow>,; *-- <nEndCol>,<nSpeed>,<nColoSet> *-- Examples....: do jazfill with 4,1,23,78,5 *-- Returns.....: None *-- Parameters..: nBegRow = Starting Row *-- nBegCol = Starting Column *-- nEndRow = Ending Row (Bottom Right) *-- nEndCol = Ending Column (Bottom Right) *-- nSpeed = How fast? *-- nColoSet = What colors to fill with *-- 1 = purple/white *-- 2 = yellow/black *-- 3 = cyan/blue *----------------------------------------------------------------------- parameters nBegRow,nBegCol,nEndRow,nEndCol,nSpeed,nColoSet private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ; mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol private nColLeft, nColRite, nRowTop, nRowBot, nWinR1a, nBlk_no private sSBar, sShade m->nWinR1 = m->nBegRow && row 1 m->nWinR2 = m->nEndRow && row 2 m->nWinC1 = m->nBegCol && column 1 m->nWinC2 = m->nEndCol && column 2 m->nStep = m->nSpeed && bursting speed(lower no. && for small windows) * set choice of colors for the fill do CASE CASE m->nColoSet = 1 m->sShade = "RB+/W" CASE m->nColoSet = 2 m->sShade = "RG+/N" CASE m->nColoSet = 3 m->sShade = "BG+/B" endcase * set starting point m->mnWinC1 = int((m->nWinC2-m->nWinC1)/2)+m->nWinC1 m->mnWinC2 = m->mnWinC1+1 m->mnWinR1 = int((m->nWinR2-m->nWinR1)/2)+m->nWinR1 m->mnWinR2 = m->mnWinR1+1 ** Adjust step offset values: nColOff & nRowOff ** Vertical steps: nWinR1-nWinR1 m->nTmpAdjR = int((m->nWinR2 - m->nWinR1)/2) m->nTmpAdjC = int((m->nWinC2 - m->nWinC1)/2) nAdjRow = ; iif(m->nTmpAdjC > m->nTmpAdjR, m->nTmpAdjR/m->nTmpAdjC,1); * m->nStep nAdjCol = ; iif(m->nTmpAdjR > m->nTmpAdjC, m->nTmpAdjC/m->nTmpAdjR,1); * m->nStep m->nColleft = m->nWinC1 m->nColrite = m->nWinC2 m->nRowTop = m->nWinR1 m->nRowBot = m->nWinR2 m->nWinC1 = m->mnWinC1 m->nWinC2 = m->mnWinC2 m->nWinR1 = m->mnWinR1 m->nWinR2 = m->mnWinR2 do while (m->nWinC1#m->nColLeft .or. m->nWinC2#m->nColRite .or. ; m->nWinR1 # m->nRowTop .or. m->nWinR2 # m->nRowBot) * Adjust coordim->nAtes for the clear (moving out from the middle) m->nWinR1 = ; m->nWinR1-iif(m->nRowTop<m->nWinR1-nAdjRow,nAdjRow,m->nWinR1-; m->nRowTop) m->nWinR2 = ; m->nWinR2+iif(m->nRowBot>m->nWinR2+nAdjRow,nAdjRow,m->nRowBot-; m->nWinR2) m->nWinC1 = ; m->nWinC1-iif(m->nColLeft<m->nWinC1-nAdjCol,nAdjCol,m->nWinC1-; m->nColLeft) m->nWinC2 = ; m->nWinC2+iif(m->nColRite>m->nWinC2+nAdjCol,nAdjCol,; m->nColRite-m->nWinC2) * Perform the clear m->nWinR1a = m->nWinR1 do while m->nWinR1a <= m->nWinR2 m->nBlk_no = m->nWinC2-m->nWinC1 m->sSBAR = replicate(chr(176),m->nBlk_no) @m->nWinR1a,m->nWinC1 say m->sSBAR color &sSHADE. m->nWinR1a = m->nWinR1a + 1 enddo enddo @ m->nWinR1,m->nWinC1 to m->nWinR2,m->nWinC2 DOUBLE RETURN *-- EoP: JazFill PROCEDURE Bord3D3 *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 05/07/1993 *-- Notes.......: Designed to take a dialog box that _doesn't_ have a *-- border defined (NONE), and is a grey box (i.e., *-- background is 'W' for color) and give a 3-d border *-- to it ... *-- ASSUMPTION: Dialog box is defined in a window ... (not *-- using @...FILL TO ... command) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 03/15/1993 -- Original *-- 05/07/1993 -- Version to give a single-line border *-- Calls.......: COLORBRK() Function in PROC.PRG *-- BackColor() Function in COLOR.PRG *-- Called by...: Any (Specifically YESNO4()) *-- Usage.......: Do Bord3D3 with <nHeight>,<nWidth>,<cColor>,<nStyle> *-- Example.....: Do Bord3D3 with 9,40,cWind1,2 *-- Returns.....: None *-- Parameters..: nHeight = height of dialog box *-- nWidth = Width of dialog box *-- cColor = Color settings used for dialog box -- *-- requires at a minimum the colors for the *-- text part (i.e, "rg+/r") *-- nStyle = 'Style' of border -- 1 = raised, 2 = inset *----------------------------------------------------------------------- parameters nHeight, nWidth, cColor, nStyle private nHeight2, nWidth2 m->cBorder = set("BORDER") && save border setting set border to single && must be single for this ... *-- figure out colors m->cTextColor = colorbrk(m->cColor,1) m->cBackColor = backcolor(m->cTextColor) m->cHighColor = "W+/"+m->cBackColor m->cShadColor = "N/"+m->cBackColor *-- if style is 1, we do the commands for a 'raised' border *-- if style is 2, we do an 'inset' border if m->nStyle < 1 .or. m->nStyle > 2 && if not 1 or 2 ... m->nStyle = 1 endif if m->nStyle = 1 *-- Outside of "border" @0,0 to 0,m->nWidth color &cHighColor. @0,0 to m->nHeight, 0 color &cHighColor. @0,0 say chr(218) color &cHighColor. @m->nHeight,0 say chr(192) color &cHighColor. @0,m->nWidth to m->nHeight,m->nWidth color &cShadColor. @m->nHeight, 1 to m->nHeight,m->nWidth color &cShadColor. @0,m->nWidth say chr(191) color &cShadColor. @m->nHeight,m->nWidth say chr(217) color &cShadColor. else *-- Outside of "border" @0,0 to 0,m->nWidth color &cShadColor. @0,0 to m->nHeight, 0 color &cShadColor. @0,0 say chr(218) color &cShadColor. @m->nHeight,0 say chr(192) color &cShadColor. @0,m->nWidth to m->nHeight,m->nWidth color &cHighColor. @m->nHeight, 1 to m->nHeight,m->nWidth color &cHighColor. @0,m->nWidth say chr(191) color &cHighColor. @m->nHeight,m->nWidth say chr(217) color &cHighColor. endif *-- reset border set border to &cBorder. RETURN *-- EoP: Bord3D3 PROCEDURE Bord3D4 *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 05/07/1993 *-- Notes.......: This variation on BORD3D was written to deal with *-- items that are "filled", rather than windows, that *-- have a set edge. This one requires that the actual *-- coordinates get passed to it. This one is a single- *-- line version of BORD3D2. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 03/18/1993 -- Original *-- 05/07/1993 -- Single-Line Version *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Do Bord3D4 with <nTop>,<nLeft>,<nBottom>,<nRight>,; *-- <cColor>,<nStyle> *-- Example.....: Do Bord3d4 with 0,15,4,60,cColor,1 *-- Returns.....: None *-- Parameters..: nTop = top row *-- nLeft = Left column *-- nBottom = Bottom Row *-- nRight = Right Column *-- cColor = Color of area being filled *-- nStyle = type of 3-d border (1 = Raised, 2 = Inset) *----------------------------------------------------------------------- parameters nTop,nLeft,nBottom,nRight,cColor,nStyle *-- deal with border ... m->cBorder = set("BORDER") *-- figure out colors m->cTextColor = colorbrk(m->cColor,1) m->cBackColor = backcolor(m->cTextColor) m->cHighColor = "W+/"+m->cBackColor m->cShadColor = "N/"+m->cBackColor *-- if style is 1, we do the commands for a 'raised' border *-- if style is 2, we do an 'inset' border if m->nStyle < 1 .or. m->nStyle > 2 && if not 1 or 2 ... m->nStyle = 1 endif if m->nStyle = 1 *-- RAISED Border *-- Outside of "border" @m->nTop,m->nLeft to m->nTop,m->nRight color &cHighColor. @m->nTop,m->nLeft to m->nBottom,m->nLeft color &cHighColor. @m->nTop,m->nLeft say chr(218) color &cHighColor. @m->nBottom,m->nLeft say chr(192) color &cHighColor. @m->nTop,m->nRight to m->nBottom,m->nRight color &cShadColor. @m->nBottom,m->nLeft+1 to m->nBottom,m->nRight color &cShadColor @m->nTop,m->nRight say chr(191) color &cShadColor. @m->nBottom,m->nRight say chr(217) color &cShadColor. else *-- RECESSED Border *-- Outside of "border" @m->nTop,m->nLeft to m->nTop,m->nRight color &cShadColor. @m->nTop,m->nLeft to m->nBottom,m->nLeft color &cShadColor. @m->nTop,m->nLeft say chr(218) color &cShadColor. @m->nBottom,m->nLeft say chr(192) color &cShadColor. @m->nTop,m->nRight to m->nBottom,m->nRight color &cHighColor. @m->nBottom,m->nLeft+1 to m->nBottom,m->nRight color &cHighColor. @m->nTop,m->nRight say chr(191) color &cHighColor. @m->nBottom,m->nRight say chr(217) color &cHighColor. endif *-- reset border set border to &cBorder. RETURN *-- EoP: Bord3D4 PROCEDURE NewBack *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/11/1993 *-- Notes.......: Based on some ideas from Mike Irwin's presentation at *-- the 4th Annual Borland International Conference (Tips *-- and Tricks), this routine will provide a textured *-- background surface using the current colors for the *-- background, and three ascii high order characters *-- (176,177,178). It is able to handle different *-- screen sizes (i.e., 25 line, 43 line and 50 line). *-- WARNING: This routine assumes that the status line *-- is turned off. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/11/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do NewBack *-- Example.....: do NewBack *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- private cScrType, nScrHeight, cString, nTimes, nTop, nBottom, nCount m->cString = replicate("∞±≤",80) && 240 = 80 characters && times three lines m->cString2 = replicate("∞±≤",26)+"∞±" && bottom row ... m->cString3 = replicate("≤∞±",26)+"≤±" && bottom for 50 line mode *-- get the screen height -- if we have a mono monitor, it is, by *-- definition, 25 lines. m->cScrType = set("DISPLAY") if m->cScrType = "MONO" m->nScrHeight = 25 else m->nScrHeight = val(right(m->cScrType,2)) endif m->nScreen = m->nScrHeight m->nScrHeight = m->nScrHeight - 1 && start at 0, remember! *-- now, how to deal with the display? We want to do a routine where *-- we display one set at the top, one at the bottom, and back to *-- the top. This tricks the eye into thinking that it's happening *-- all at once, rather than top to bottom ... if m->nScrHeight/3 = int(m->nScrHeight/3) m->nTimes = m->nScrHeight/3 else m->nScrHeight = m->nScrHeight - 1 if m->nScrHeight/3 = int(m->nScrHeight/3) m->nTimes = m->nScrHeight/3 else m->nScrHeight = m->nScrHeight - 1 m->nTimes = m->nScrHeight/3 endif endif m->nTimes = m->nTimes / 2 *-- Now for a display loop ... m->nTop = 0 m->nBottom = m->nScrHeight - 3 m->nCount = 0 do while m->nCount < m->nTimes m->nCount = m->nCount + 1 @ m->nTop,0 say m->cString @m->nBottom,0 say m->cString m->nTop = m->nTop + 3 m->nBottom = m->nBottom - 3 enddo do case case m->nScreen = 25 .or. m->nScreen = 43 @m->nScreen-1,0 say m->cString2 case m->nScreen = 50 @48,0 say m->cString2 @49,0 say m->cString3 endcase RETURN *-- EoP: NewBack FUNCTION Bevel *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (Borland) *-- Date........: 04/xx/1993 *-- Notes.......: Taken from the April/May issue of dTech News. *-- This routine will create a 'beveled' area on the *-- screen (3-d border). This is done by passing two *-- parameters, and using the @/SAY for the starting *-- coordinates. This defaults to the Borland "chiseled *-- steel" look. If you want other colors, you will need *-- to modify this routine (or use a different one, such *-- as BORD3D or BORD3D2 in PROC.PRG). *-- Quoting from the article: *-- "Placing text in the screen should be done before *-- the function is called. This way, the background color *-- can blend in, though the text colors will become *-- black. If you do not want the text to display in *-- black but still want it to blend, determine the dull *-- color color (which is the value of cClrBack in the *-- program) and @...SAY the text with <your color>/ *-- <dull color>. See the [code] for getting colors, and *-- use the code for getting cClrBack. For example, *-- if your colors are "W+/B", the background color will *-- be "W" ("+" is stripped). Assuming this was stored to *-- the variable cBackColor and you wanted red text, the *-- syntax would look like: *-- @ 5, 5 say bevel(10,60) *-- @10,27 say "Hello World" COLOR R/&cBackColor. *-- "Another feature of the UDF is the shadowing. The *-- shadowing effect is evened out by using 1/2 height *-- shadowing on the horizontal surface and the upper *-- right hand corner. This gives it a more natural *-- appearance than trying to even out the aspect ratio *-- by using full height shadowing for the bottom, *-- and double for the right edge. This will not work *-- properly if you shade the entire background with a *-- character (chr(178) as an example." *-- Written for.: dBASE IV, 2.0 (should work with earlier versions) *-- Rev. History: 04/xx/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: @<x>,<y> say Bevel(<nBottom>,<nRight>) *-- Example.....: @5,10 say bevel(10,60) *-- Returns.....: nul *-- Parameters..: nBottom = bottom row *-- nRight = right column *----------------------------------------------------------------------- parameters nBottom, nRight private nTop, nLeft, nBottom, nRight, cAttr, cBorder, cNormFore, ; cEnh, cClrFore, cClrBack, cClrShad m->nTop = row() m->nLeft = col() m->nBottom = iif(pcount() < 1, max(25,val(right(set("DISPLAY"),; 2))) - 2, m->nBottom+m->nTop) && maximum: lastrow - 1 m->nRight = iif(pcount() < 2, 78, m->nLeft+m->nRight) && maximum 78 *-- get current color settings for highlighting m->cAttr = set("ATTRIBUTES") m->cEnh = substr(m->cAttr,at(",",m->cAttr)+1,; at(",",m->cAttr,2)-1-at(",",m->cAttr)) m->cNormBack = substr(m->cAttr,at("/",m->cAttr)+1,; at(",",m->cAttr)-1-at("/",m->cAttr)) m->cClrFore = left(m->cAttr,at("/",m->cAttr)-1) m->cClrFore = m->cClrFore+iif("+"$m->cClrFore,"","+") m->cClrFore = iif(m->cClrFore = "N+","W+",m->cClrFore) m->cClrBack = left(m->cClrFore,len(m->cClrFore) - ; iif(right(m->cClrFore,1) = "+",1,0)) m->cClrShad = "N" m->cBorder = set("BORDER") *-- fill region with color @m->nTop, m->nLeft -1 fill to m->nBottom, m->nRight ; color /&cClrBack. *-- draw shadow @m->nTop+1,m->nRight+1 fill to m->nBottom,m->nRight+1 ; color /&cClrShad. @m->nTop,m->nRight+1 say chr(220) color &cClrShad./&cNormBack. @m->nBottom+1,m->nLeft+1 say replicate(chr(223),m->nRight-; m->nLeft+1); color &cClrShad./&cNormBack. *-- Draw outer lines and highlights @m->nTop+1,m->nLeft to m->nBottom - 1,m->nLeft ; color &cClrFore./&cClrBack. @m->nBottom,m->nLeft+1 to m->nBottom,m->nRight - 1; color &cClrShad./&cClrBack. @m->nTop,m->nLeft+1 to m->nTop,m->nRight - 1 ; color &cClrFore./&cClrBack. @m->nTop+1,m->nRight to m->nBottom-1,m->nRight ; color &cClrShad./&cClrBack. *-- Draw inner lines and highlights @m->nTop+2,m->nLeft+2 to m->nBottom-2,m->nLeft+2 ; color &cClrShad./&cClrBack. @m->nBottom-1,m->nLeft+3 to m->nBottom-1,m->nRight-3 ; color &cClrFore./&cClrBack. @m->nTop+1,m->nLeft+3 to m->nTop+1,m->nRight-3 ; color &cClrShad./&cClrBack. @m->nTop+2,m->nRight-2 to m->nBottom-2,m->nRight-2 ; color &cClrFore./&cClrBack. *-- Draw outer corners @m->nTop,m->nLeft say chr(218) color &cClrFore./&cClrBack. @m->nBottom,m->nLeft say chr(192) color &cClrFore./&cClrBack. @m->nTop,m->nRight say chr(191) color &cClrShad./&cClrBack. @m->nBottom,m->nRight say chr(217) color &cClrShad./&cClrBack. *-- Draw inner corners @m->nTop+1,m->nLeft+2 say chr(218) color &cClrShad./&cClrBack. @m->nBottom-1,m->nLeft+2 say chr(192) color &cClrShad./&cClrBack. @m->nTop+1,m->nRight-2 say chr(191) color &cClrFore./&cClrBack. @m->nBottom-1,m->nRight-2 say chr(217) color &cClrFore./&cClrBack. *-- cleanup set border to &cBorder. RETURN "" *-- EoF: Bevel() FUNCTION Warning *---------------------------------------------------------------------- *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223) *-- Date........: 10/26/1993 *-- Notes.......: quick-and-dirty warning message for testing -- *-- WARNING -- will overwrite bottom of screen ... *-- suggest using SAVE/RESTORE Screen ... (KJM) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 10/26/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ? Warning(<c1>[,<c2>,<c3>,<c4>,<c5>]) *-- Example.....: ? Warning("You dummy!") *-- Returns.....: .F. *-- Parameters..: Up to five character strings to display at EoScreen *---------------------------------------------------------------------- parameters cM1, cM2, cM3, cM4, cM5 private cDevice, lConsole, lPrintON lConsole = set("console") = "ON" lPrintON = set("printer") = "ON" cDevice = set("device") set print off set device to screen set console on do case case pcount() = 1 @ 23,0 clear to 24,79 @ 23,0 say left(m->cM1,79) case pcount() = 2 @ 22,0 clear to 24,79 @ 22,0 say left(m->cM1,79) @ 23,0 say left(m->cM2,79) case pcount() = 3 @ 21,0 clear to 24,79 @ 21,0 say left(m->cM1,79) @ 22,0 say left(m->cM2,79) @ 23,0 say left(m->cM3,79) case pcount() = 4 @ 20,0 clear to 24,79 @ 20,0 say left(m->cM1,79) @ 21,0 say left(m->cM2,79) @ 22,0 say left(m->cM3,79) @ 23,0 say left(m->cM4,79) otherwise * use the first five @ 19,0 clear to 24,79 @ 19,0 say left(m->cM1,79) @ 20,0 say left(m->cM2,79) @ 21,0 say left(m->cM3,79) @ 22,0 say left(m->cM4,79) @ 23,0 say left(m->cM5,79) endcase @ 24,0 say "Press any key to continue ... " + chr(7) lDummy = inkey(0) do case case trim(m->cDevice) = "PRINT" set device to PRINT case trim(m->cDevice) = "SCREEN" set device to SCREEN case left(m->cDevice,4) = "FILE" store substr(m->cDevice,5) to cDevice set device to FILE (m->cDevice) otherwise @ 24,0 clear to 24,79 @ 24,0 say chr(7) + "UNKNOWN DEVICE IN Warning: "+; m->cDevice+" press any key" lDummy = inkey(0) endcase if .not.lConsole set console off endif if lPrintON set printer on endif RETURN .F. *-- EoF: Warning() FUNCTION FRAME *----------------------------------------------------------------------- *-- Programmer..: Peter Stevens - HMRS (CIS:100114,301) *-- Date........: Nov 15th 1993 *-- Notes.......: Frames up to 3 lines of text with double line border *-- Written for.: dBASE IV 1.5 (All?) *-- Rev. History: 09/05/1993 - Original program *-- 11/09/1993 - Centering option added (Peter Stevens) *-- 11/15/1993 - Calls SHADE to draw 3D shadow *-- See Function SHADE below *-- Calls.......: Shade() *-- Called by...: Any *-- Usage.......: Frame(nBegRow,nBegCol,nEndRow,nEndCol,"cText1 ", *-- "cText2 ","cText3 ","color1/color2",.T.) *-- Example.....: x=Frame(10,10,13,20,"Line # 1 ","Line # 2 ",; *-- "Line # 3 ","RG+/R",.T.) *-- Returns.....: "" *-- Params......: nBegRow = start row *-- nBegCol = start col *-- nEndRow = end row *-- nEndCol = end col of fill *-- cText1 = TextString1 *-- cText2 = TextString2 *-- cText3 = TextString3 *-- cColor = colors *-- lCenter = center toggle *-- Could be expanded for more lines but remember *-- the buffer max of 220 chars. *-- Each text string should have a _trailing_ space. *-- If lCenter is set true the Col params are re-set *-- _and_ cText1 will set the width of the frame! *----------------------------------------------------------------------- parameters nBegRow,nBegCol,nEndRow,nEndCol,cText1,cText2,cText3,; cColor,lCenter private nBegRow,nBegCol,nEndRow,nEndCol,nStartRow,nStartCol,; nLastRow,nLastCol *-- Specify co-ords for SHADE m->nStartRow = m->nBegRow m->nLastRow = m->nEndRow m->nStartCol = m->nBegCol m->nLastCol = m->nEndCol m->cText1 = " "+m->cText1 && Adds leading space to m->cText1 if len(m->cText2) > 0 m->cText2 = " "+m->cText2 endif if len(m->cText3) > 0 m->cText3 = " "+m->cText3 endif if m->lCenter && reset the col co-ords if 2b center m->nBegCol = (80-len(m->cText1))/2 m->nEndCol = (80-len(m->cText1))/2+(len(m->cText1)) m->nStartCol = m->nBegCol && and reset col co-ords for SHADE m->nLastCol = m->nEndCol endif *-- Clear screen and draw box @ m->nBegRow-1,m->nBegCol-1 clear to m->nEndRow,m->nEndCol @ m->nBegRow-1,m->nBegCol-1 fill to m->nEndRow,m->nEndCol ; color &cColor. @ m->nBegRow-1,m->nBegCol-1 to m->nEndRow,m->nEndCol double ; color &cColor. *-- say first line of text @ m->nBegRow,m->nBegCol say m->cText1 color &cColor. if m->lCenter && reset the start column for cText2 m->nBegCol = (80-len(m->cText2))/2 endif m->nBegRow = m->nBegRow + 1 && jump to next row *-- say second line of text @ m->nBegRow,m->nBegCol say m->cText2 color &cColor. if m->lCenter && reset the start column for cText3 m->nBegCol = (80-len(m->cText3))/2 endif m->nBegRow = m->nBegRow + 1 && jump to next row *-- say third line of text @ m->nBegRow,m->nBegCol say m->cText3 color &cColor. *-- Call SHADE to do its stuff x=Shade(m->nStartRow,m->nStartCol,m->nLastRow,m->nLastCol) RETURN "" *-- EoF Frame() FUNCTION SHADE *---------------------------------------------------------------------- *-- Programmer..: Peter Stevens (CIS:100114,301) *-- Date........: 11/05/1993 *-- Notes.......: Gives 3D shadow, replaces SHADOWG on LIB201 *-- This function only draws shaded part on right and bott *-- edges of window or popup like an inverted L. The new *-- co-ords are calculated here rather than by the *-- programmer. Text under the shadow shows through. *-- Uses the same co-ords as popup or window you want *-- shaded *-- Written for.: dBASE IV 1.5 (All?) *-- Rev. History: 11/05/1993 -- Original program *-- Calls ......: None *-- Called by ..: Any *-- Usage ......: SHADE(nBegRow,nBegCol,nEndRow,nEndCol) *-- Example ....: x=SHADE(10,10,13,20) *-- Returns ....: "" *-- Params .....: nBegRow = start row *-- nBegCol = start col *-- nEndRow = end row *-- nEndCol = end col *----------------------------------------------------------------------- parameters nBegRow,nBegCol,nEndRow,nEndCol private nBegRow,nBegCol,nEndRow,nEndCol *-- Recalculate the start positions of the co-ords m->nBegCol = m->nBegCol + 2 m->nEndRow = m->nEndRow + 1 m->nEndCol = m->nEndCol + 1 *-- Draw the vertical line do while m->nBegRow <> m->nEndRow m->nBegRow = m->nBegRow + 1 @ m->nBegRow,m->nEndCol fill to m->nBegRow,m->nEndCol+1 color N/GR enddo *-- Draw the horizontal line @ m->nEndRow,m->nBegCol fill to m->nEndRow,m->nEndCol+1 color N/GR RETURN "" *-- EoF: Shade() FUNCTION BurstWin *----------------------------------------------------------------------- *-- Programmer..: Peter Stevens (CIS:100114,301) *-- Date........: 11/28/1993 *-- Notes.......: Draws a bursting pseudo-window with chr(177) in-fill *-- The speed parameter determines the rate at which *-- horizontal expansion of the window occurs. *-- Written for.: dBASE IV 1.5 (All?) *-- Rev. History: 11/28/1993 - Original program *-- Calls.......: None *-- Called by...: Any *-- Usage.......: BurstWin(<nBeginRow>,<nBeginCol>,<nEndRow>,; *-- <nEndCol>,<nStep>,<cColor>) *-- Example.....: x=BurstWin(10,10,13,20,2,"GR+/GR") *-- Returns.....: "" *-- Parameters..: nBeginRow = Starting Row *-- nBeginCol = Starting Column *-- nEndRow = Ending Row *-- nEndCol = Ending Column *-- nStep = Increment window size by x *-- cColor = Colors (forg/back) of window *----------------------------------------------------------------------- parameters nBegRow,nBegCol,nEndRow,nEndCol,nStep,cColor private m->nWidTH,m->nDepth private m->nFirstRow,m->nFirstCol,m->nLastRow,m->nLastCol,nRow private cFill,nFill,m->l_Done1,m->l_Done2,m->l_Done3,m->l_Done4 store .F. to m->l_Done1,m->l_Done2,m->l_Done3,m->l_Done4 m->nDepth = m->nEndRow - m->nBegRow m->nWidth = m->nEndCol - m->nBegCol *-- Determine the size & starting position of the first window m->nFirstRow = int((m->nBegRow+(m->nDepth/2))-1) m->nFirstCol = m->nBegCol+int((m->nWidth/2)-m->nStep) m->nLastRow = int((m->nEndRow-(m->nDepth/2))+1) m->nLastCol = int((m->nBegCol+(m->nWidth/2))+m->nStep) *-- Then draw it @ m->nFirstRow,m->nFirstCol to m->nLastRow,m->nLastCol double ; color &cColor. do while .t. *-- Set the window 1 row higher and expand it by nStep do while .not. m->l_Done1 .or. .not. m->l_Done3 if m->nLastRow-m->nFirstRow <= m->nDepth m->nFirstRow = m->nFirstRow - 1 if m->nFirstRow < m->nBegRow && if Row is up too high m->nFirstRow = m->nBegRow && reset to passed param m->l_Done1 = .T. && and set l_Done1 as && complete endif endif if m->nLastCol - m->nFirstCol < m->nWidth+m->nStep m->nFirstCol = m->nFirstCol - m->nStep if m->nFirstCol < m->nBegCol && If Col is too far left m->nFirstCol = m->nBegCol && reset to passed param m->l_Done3 = .T. && and l_Done2 is complete endif endif *-- Draw the new window @ m->nFirstRow,m->nFirstCol to m->nLastRow,m->nLastCol double; color &cColor. *-- Then fill it - delete to where shown if running on a slow *-- machine nRow = m->nFirstRow+1 nFill = (m->nLastCol)-(m->nFirstCol+1) do while nRow <= m->nLastRow-1 cFill = replicate(chr(177),nFill) @ nRow,m->nFirstCol+1 SAY cFill nRow = nRow + 1 enddo *-- Delete to here if applicable exit enddo *-- Introduce a delay (optional for 486 procs) * out if not reqd. i = inkey(0.08) *-- Set the window 1 row lower and expand it by nStep do while .not. m->l_Done2 .or. .not. m->l_Done4 if m->nLastRow-m->nFirstRow <= m->nDepth m->nLastRow = m->nLastRow + 1 if m->nLastRow > m->nEndRow && If Row is too low m->nLastRow = m->nEndRow && Reset it to passed param m->l_Done2 = .T. && and l_Done3 is complete endif endif if m->nLastCol - m->nFirstCol < m->nWidth+m->nStep m->nLastCol = m->nLastCol + m->nStep if m->nLastCol > m->nEndCol && If Col is too far right m->nLastCol = m->nEndCol && Reset it to passed param m->l_Done4 = .T. && and l_Done4 is complete endif endif *-- Draw the new window @ m->nFirstRow,m->nFirstCol to m->nLastRow,m->nLastCol double; color &cColor. *-- And fill it - Delete to where shown if on a slow machine nRow = m->nFirstRow+1 nFill = (m->nLastCol)-(m->nFirstCol+1) do while nRow <= m->nLastRow-1 cFill = replicate(chr(177),nFill) @ nRow,m->nFirstCol+1 SAY cFill nRow = nRow + 1 *-- Delete to here if applicable enddo exit enddo *-- Introduce a small delay as above i = inkey(0.08) *-- Check that window is to specfied size if m->l_Done1 .and. m->l_Done2 .and. m->l_Done3 .and. m->l_Done4 exit endif enddo *-- Then fill it - delete to where shown if running on a FAST machine nRow = m->nFirstRow+1 nFill = (m->nLastCol)-(m->nFirstCol+1) do while nRow <= m->nLastRow-1 cFill = replicate(chr(177),nFill) @ nRow,m->nFirstCol+1 SAY cFill nRow = nRow + 1 enddo *-- Delete to here if applicable *-- Optional Extra - Draw a 3-D shadow m->nBegRow = m->nBegRow + 1 m->nBegCol = m->nBegCol + 2 m->nEndRow = m->nEndRow + 1 m->nEndCol = m->nEndCol + 1 @ m->nBegRow,m->nEndCol fill to m->nEndRow,m->nEndCol+1 color n+/n @ m->nEndRow,m->nBegCol fill to m->nEndRow,m->nEndCol+1 color n+/n RETURN "" *-- EoF: BurstWin() *----------------------------------------------------------------------- *-- Library functions included for convenience *----------------------------------------------------------------------- FUNCTION NormColors *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/23/1993 *-- Notes.......: Returns the "normal" portion of a color string *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/23/1993 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: NormColors( <cColor> ) *-- Example.....: ? NormColors( "N/BG,BG+/N,W+/B" ) *-- Parameters..: cColor - String holding colors *-- Returns.....: Character, normal color portion of string. *----------------------------------------------------------------------- parameters cColor private cRet m->cRet = m->cColor if "," $ m->cRet m->cRet = left( m->cRet, at( ",", m->cRet ) - 1 ) endif RETURN upper( ltrim( trim ( m->cRet ) ) ) *-- EoF: NormColors() FUNCTION HighColors *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/23/1993 *-- Notes.......: Returns the "highlight" portion of a color string *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/23/1993 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: HighColors( <cColor> ) *-- Example.....: ? HighColors( "N/BG,BG+/N,W+/B" ) *-- Parameters..: cColor - String holding colors *-- Returns.....: Character, highlight color portion of string. *-- Returns empty string if no such portion. *----------------------------------------------------------------------- parameters cColor private cRet m->cRet = "" if "," $ m->cColor m->cRet = substr( m->cColor, at( ",",m->cColor ) + 1 ) if "," $ m->cRet m->cRet = left( m->cRet, at( ",", m->cRet ) - 1 ) endif endif RETURN upper( ltrim( trim( m->cRet ) ) ) *-- EoF: HighColors() FUNCTION ForeColor *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/24/1993 *-- Notes.......: Returns foreground part of color string. *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/24/1993 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ForeColor( <cColor> ) *-- Example.....: ? ForeColor( "N/BG" ) *-- Parameters..: cColor - String holding color foreground and *-- background *-- Returns.....: Character, string with foreground portion of the color *----------------------------------------------------------------------- parameters cColor private cRet m->cRet = upper( trim( ltrim( m->cColor ) ) ) if "/" $ m->cRet m->cRet = left( m->cRet, at( "/", m->cRet ) - 1 ) endif if "*" $ m->cColor m->cRet = m->cRet + "*" endif if "+" $ m->cColor m->cRet = m->cRet + "+" endif RETURN m->cRet *-- EoF: ForeColor() PROCEDURE Center *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/24/1991 *-- Notes.......: Centers text on the screen with @says *-- Written for.: dBASE IV, 1.1 *-- Rev. History: This and all other procedures/functions listed in this *-- file attributed to Miriam Liskin came from "Liskin's *-- Programming dBASE IV Book". Very good, worth the money *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>" *-- Example.....: do center with 5,65,"RG+/GB",; *-- "WARNING! This will blow up!" *-- Note that the color field may be blank: "" *-- Returns.....: None *-- Parameters..: nLine = Line or Row for @/Say *-- nWidth = Width of screen *-- cColor = Colors to be used ("Forg/Back") *-- (may be nul "", in order to use the default *-- colors of window/screen) *-- cText = Message to center on screen *----------------------------------------------------------------------- parameters nLine,nWidth,cColor,cText private nCol m->nCol = (m->nWidth - len(m->cText)) /2 @m->nLine,m->nCol say m->cText color &cColor. RETURN *-- EoP: Center FUNCTION ArrayRows *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Number of Rows in an array *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 03/01/1992 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ArrayRows("<aArray>") *-- Example.....: n = ArrayRows("aTest") *-- Returns.....: numeric *-- Parameters..: aArray = Name of array *----------------------------------------------------------------------- parameters aArray private nHi, nLo, nTrial, nDims m->nLo = 1 m->nHi = 1170 if type( "&aArray.[ 1, 1 ]" ) = "U" m->nDims = 1 else m->nDims = 2 endif do while .T. m->nTrial = int( ( m->nHi + m->nLo ) / 2 ) if m->nHi < m->nLo exit endif if m->nDims = 1 .and. type( "&aArray[ m->nTrial ]" ) = "U" .or. ; m->nDims = 2 .and. type( "&aArray[ m->nTrial, 1 ]" ) = "U" m->nHi = m->nTrial - 1 else m->nLo = m->nTrial + 1 endif enddo RETURN m->nTrial *-- EoF: ArrayRows() PROCEDURE ReColor *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 04/23/1992 *-- Notes.......: Restores colors to those held in a string of the form *-- returned by set("ATTRIBUTE"). *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: 04/23/1992 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DO ReColor WITH <cColors> *-- Example.....: DO Recolor WITH OldColors *-- Parameters..: cColors = a string in the form returned by *-- set("ATTRIBUTE"). *-- Returns.....: None *-- Side effects: Changes the screen colors. *----------------------------------------------------------------------- parameters cColors private cThis, cNext, nAt, cLeft, nX, cAreas m->cAreas = " NORMHIGHBORDMESSTITLBOX INFOFIEL" m->cLeft = m->cColors + ", " m->nX = 0 do while m->nX < 8 m->nX = m->nX + 1 cThis = substr( m->cAreas, 4 * m->nX, 4 ) if m->nX = 3 m->nAt = at( "&", m->cLeft ) m->cNext = left( m->cLeft, m->nAt - 2 ) m->cLeft = substr( m->cLeft, m->nAt + 3 ) SET COLOR TO , , &cNext. else m->nAt = at( ",", m->cLeft ) m->cNext = left( m->cLeft, m->nAt - 1 ) m->cLeft = substr( m->cLeft, m->nAt + 1 ) SET COLOR OF &cThis. TO &cNext. endif enddo RETURN *-- EoP: ReColor *----------------------------------------------------------------------- *-- EoP: SCREEN.PRG *-----------------------------------------------------------------------